EXCEL VBA将一周的数据复制到不同的工作表中

Question

我在工作簿中有两张纸，一张包含所有数据（“hdagarb”），另一张是“摘要”。在数据表中，第 2 列有名称，第 5 列有日期。这些是我关心的列。我想获取在 6 月 9 日结束的一周内的所有行，并复制第 2 列中的名称和第 5 列中的日期并将其粘贴到我的摘要表中。目前我什至无法复制和粘贴第 2 列的名称。这是我的代码：

Sub finddata()


Dim todaysdate As Date
Dim thisweek As Date
Dim lastweek As Date
Dim finalrow As Long
Dim Rdate As Date
Dim i As Long

Sheets("Summary").Range("H5:H1000").ClearContents

todaysdate = Date
thisweek = (7 - Weekday(todaysdate, vbSaturday)) + todaysdate
lastweek = (7 - Weekday(todaysdate, vbSaturday)) + todaysdate - 7


finalrow = Sheets("HDAGarb").Range("A100000").End(xlUp).Row


For i = 2 To finalrow

Rdate = Sheets("hdagarb").Cells(i, 5)

If Rdate > lastweek Then
    Sheets("hdagarb").Cells(i, 2).Copy
    Sheets("Summary").Range("H100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
    End If

Next i


Worksheets("summary").Activate
Worksheets("summary").Range("H5").Select

End Sub

第5列的源数据是这样的

02-Jun-2017  
-  
-  
-  
-  
12-Apr-2017  
01-May-2017  

我希望脚本忽略不带日期的条目（“-”）。

Answer 1

只有在 E 列中有有效日期时，以下代码才会执行​​复制：

Sub finddata()
    Dim todaysdate As Date
    Dim thisweek As Date
    Dim lastweek As Date
    Dim finalrow As Long
    Dim newRow As Long
    Dim Rdate As Date
    Dim i As Long
    Dim srcSheet As Worksheet
    Dim dstSheet As Worksheet

    todaysdate = Date
    thisweek = (7 - Weekday(todaysdate, vbSaturday)) + todaysdate
    lastweek = (7 - Weekday(todaysdate, vbSaturday)) + todaysdate - 7

    Set srcSheet = Worksheets("HDAGarb")
    Set dstSheet = Worksheets("Summary")

    finalrow = srcSheet.Range("A" & srcSheet.Rows.Count).End(xlUp).Row

    dstSheet.Range("H5:H" & dstSheet.Cells(dstSheet.Rows.Count, "H").End(xlUp).Row).ClearContents
    newRow = 4

    For i = 2 To finalrow
        If IsDate(srcSheet.Cells(i, "E").Value) Then
            Rdate = CDate(srcSheet.Cells(i, 5).Value)

            If Rdate > lastweek Then 'or If Rdate > lastweek And Rdate <= thisweek Then  '???
                newRow = newRow + 1
                srcSheet.Cells(i, "B").Copy
                dstSheet.Cells(newRow, "H").PasteSpecial xlPasteFormulasAndNumberFormats
                'Not sure whether you wanted the next two lines
                srcSheet.Cells(i, "E").Copy
                dstSheet.Cells(newRow, "I").PasteSpecial xlPasteFormulasAndNumberFormats
            End If
        End If
    Next i

    dstSheet.Activate
    dstSheet.Range("H5").Select
End Sub

我还更改了它以跟踪摘要表中写入的行，这样，如果 HDAGarb 表中的名称之一为空白，它仍会复制它和关联的日期。 （如果您不必不断重新计算最后一行，它也会更快。）