日付と同じ列にデータを貼り付けループ

Question

シート2の日付がシート3の日付と一致するかどうかを調べるマクロがあります。日付が見つかった場合は、同じ行のシート3にデータをコピーするマクロが必要です日付。

問題、私はシートに日付と同じライン上のデータを貼り付けることができないではないよ3.

問題II - 私はそれように私のマクロでループを設定する必要がありますシート2のすべての日付をチェックします。現在、日付は1つのみです。

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

Answer 1

辞書やコレクションは、リストを比較するための理想的です。あなたは見てください：Excel VBA Introduction Part 39 - Dictionaries

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