Question

我在工作簿中有2张纸，其中一张包含所有数据（“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表中的某个名称为空，它仍会复制它和相关的日期。（如果你不必重新计算哪一行是最后一行，它也会更快。）

EXCEL VBA将数据从一周复制到另一张表中

1 个答案: