Vba 将数据粘贴到与“发现日期”循环相同的列上

我有一个宏，它可以查看表2中的日期是否与表3中的日期匹配，如果找到日期，我需要宏将数据复制到表3中与日期相同的行上

问题，我无法将数据粘贴到与表3中的日期相同的行上

问题二-我需要在我的宏中设置一个循环，以便它检查表2中的所有日期，目前它只选择一个日期

Option Explicit
Sub CopyIt()
  Dim CheckDate As Date
  Dim FoundRow As Integer
  Dim Range_T0_Search As String

  '** get the date you are looking for from sheet 3 cell D2 ***
  CheckDate = Sheet3.Range("D2").Value

  '****
  Range_T0_Search = "A2:A" & Trim(Str(Sheet2.Cells(2, 1).End(xlDown).Row))
  FoundRow = findIt(Range_T0_Search, CheckDate)


     '*** if it can't find the date on sheet2 then don't copy anything
  If FoundRow = 0 Then Exit Sub

  '*** do the USD bit *****

  Sheet3.Cells(6, 6) = Sheet2.Cells(FoundRow, 3) '*** copy across usd income ***
  Sheet3.Cells(6, 7) = Sheet2.Cells(FoundRow, 5) '*** copy across usd Expensies ***
  Sheet3.Cells(6, 8) = Sheet2.Cells(FoundRow, 7) '*** copy across usd Tax ***

  '*** Do the Euro bit ****

  Sheet3.Cells(6, 11) = Sheet2.Cells(FoundRow, 2) '*** copy across usd income ***
  Sheet3.Cells(6, 12) = Sheet2.Cells(FoundRow, 4) '*** copy across usd Expensies ***
  Sheet3.Cells(6, 13) = Sheet2.Cells(FoundRow, 6) '*** copy across usd Tax ***


End Sub

Function findIt(Dates_Range As String, Date_To_Find As Date) As Integer
  Dim C As Variant
  Dim Address As Range

  With Sheet2.Range(Dates_Range)
    Set C = .Find(Date_To_Find, LookIn:=xlValues)
    If Not C Is Nothing Then
        findIt = Range(C.Address).Row
    End If
End With

End Function

第3页

---

字典和集合是比较列表的理想工具。你应该看：

---

完美，做正确的事。非常感谢你

Sub CopyIt()
    Dim cell As Range, dateRow As Range
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    With Sheet2
        For Each cell In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
            If Not dict.Exists(cell.Value2) Then dict.Add cell.Value2, cell
        Next
    End With

    With Sheet3
        For Each cell In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
            If dict.Exists(cell.Value2) Then
                Set dateRow = dict(cell.Value2).EntireRow
                With cell.EntireRow
                    '*** do the USD bit *****
                    .Cells(1, 6) = dateRow.Cells(1, 3)    '*** copy across usd income ***
                    .Cells(1, 7) = dateRow.Cells(1, 5)    '*** copy across usd Expensies ***
                    .Cells(1, 8) = dateRow.Cells(1, 7)    '*** copy across usd Tax ***
                    '*** Do the Euro bit ****
                    .Cells(1, 11) = dateRow.Cells(1, 2)    '*** copy across usd income ***
                    .Cells(1, 12) = dateRow.Cells(1, 4)    '*** copy across usd Expensies ***
                    .Cells(1, 13) = dateRow.Cells(1, 6)    '*** copy across usd Tax ***
                End With
            End If
        Next
    End With

End Sub