查找具有值，偏移和復制范圍的單元格，然后粘貼基礎數據的日期，然后循環到findnext

Question

使用以下Excel表格。

我正在嘗試執行以下操作：

1. 找到具有Value的單元格，讓我們說“Sam”，在范圍內（“B17：B25”）
2. 偏移（0,5）.resize（8）.copy
3. 找到數據行的日期值，並根據數據的日期將數據粘貼到范圍（“B4：M4”）。
4. 循環找到下一個。

這是我到目前為止所得到的，不知道如何循環：

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

這是簡化版（未經測試）

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