Question

我迫切希望让这个宏工作。我想要一个按钮单击以提示用户输入开始和结束日期，然后宏来复制B：F中的单元格数据，其中单元格A *包含从第4行开始的范围内的日期。然后它会聚焦到目的地工作表并将信息粘贴到从第7行开始的H：L列。

源表看起来像这样，其中第1-3行专门用于表信息，应该免于宏的分析

   |   A  |  B  |  C  |  D  |  E  |  F  |
-----------------------------------------
4  | Date |INFO |INFO |INFO |INFO |INFO |
5  | Date |INFO |INFO |INFO |INFO |INFO |
6  | Date |INFO |INFO |INFO |INFO |INFO |
7  | Date |INFO |INFO |INFO |INFO |INFO |

目标表格如下所示，第1-6行用于表单信息。

   |  H  |  I  |  J  |  K  |  L  |
----------------------------------
7  |INFO |INFO |INFO |INFO |INFO | 
8  |INFO |INFO |INFO |INFO |INFO |
9  |INFO |INFO |INFO |INFO |INFO |
10 |INFO |INFO |INFO |INFO |INFO |

我尝试将代码拼凑在一起的代码是

Sub Copy_Click()

Dim r As Range
Set r = Range("B:F")

startdate = CDate(InputBox("Begining Date"))
enddate = CDate(InputBox("End Date"))

For Each Cell In Sheets("SOURCE").Range("A:A")
    If Cell.Value >= startdate And Cell.Value <= enddate Then
        Sheets("SOURCE").Select
        r.Select
        Selection.Copy

        Sheets("DESTINATION").Select
        ActiveSheet.Range("H:L").Select
        ActiveSheet.Paste
        Sheets("SOURCE").Select
    End If
Next

End Sub

这显然不起作用，并且没有说明将其粘贴到下一个可用行，也不会在粘贴到目标工作表时从第7行开始。

任何帮助都会很棒！

Answer 1

未测试：

Sub Copy_Click()

    Dim startdate As Date, enddate As Date
    Dim rng As Range, destRow As Long
    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim c As Range

    Set shtSrc = Sheets("SOURCE")
    Set shtDest = Sheets("DESTINATION")

    destRow = 7 'start copying to this row

    startdate = CDate(InputBox("Begining Date"))
    enddate = CDate(InputBox("End Date"))

    'don't scan the entire column...
    Set rng = Application.Intersect(shtSrc.Range("A:A"), shtSrc.UsedRange)

    For Each c In rng.Cells
        If c.Value >= startdate And c.Value <= enddate Then
            'Starting one cell to the right of c,
            '  copy a 5-cell wide block to the other sheet,
            '  pasting it in Col H on row destRow
            c.Offset(0, 1).Resize(1, 5).Copy _
                          shtDest.Cells(destRow, 8)

            destRow = destRow + 1

        End If
    Next

End Sub

Excel - 复制＆amp;当date在两个用户设置参数之间时，将单元格粘贴到范围内

1 个答案: