find具有值的单元格，偏移量和复制范围，然后粘贴基础数据的date，然后循环查找下一个

随着下面的Excel表。

我正在尝试执行以下操作：

1. find值为“Sam”的单元格（“B17：B25”）
2. 偏移（0,5）.resize（8）.copy
3. find数据行的date值，并根据数据的date粘贴数据到范围（“B4：M4”）。
4. 循环find下一个。

这是我到目前为止，不知道如何循环：

Sub getDat() Dim myFind As Range Dim pasteLoc As Range Dim payee, pasteMon As String Range("B5:M12").ClearContents With Sheet3.Cells payee = Range("B2").Text Set myFind = .Find(What:=payee, After:=Range("B16"), LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=True, SearchFormat:=False) If Not myFind Is Nothing Then myFind.Offset(0, 3).Resize(, 8).Copy pasteMon = myFind.Offset(0, 1).Text With Range("B4:M4") Set pasteLoc = .Find(What:=pasteMon, LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=True, SearchFormat:=False) If Not pasteLoc Is Nothing Then pasteLoc.Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=True End If End With End If End With End Sub 

Answer 1

这里是简化的版本（未testing）

 Sub getDat() Range("B5:M12").ClearContents Dim c As Range, r As Range For Each c in Range("B16").CurrentRegion.Columns(1).Cells If c = Range("B2") Then Set r = Range("B4:M4").Find(c(, 2)) If Not r Is Nothing Then r(2).Resize(8) = Application.Transpose(c(, 4).Resize(, 8)) End If End If Next End Sub 

Answer 2

像这样For循环也会工作：

 Sub getDat() Dim payee As String Dim lastrow As Long lastrow = Cells(Rows.Count, "B").End(xlUp).Row payee = Range("B2").Value Range("B5:M12").ClearContents For x = 17 To lastrow If Cells(x, 2).Value = payee Then For y = 2 To 13 If Cells(4, y).Value = Cells(x, 3).Value Then Range("E" & x & ":L" & x).Copy ActiveSheet.Range(Cells(5, y), Cells(12, y)).PasteSpecial Transpose:=True Exit For End If Next y End If Next x End Sub