Question

使用以下Excel表格。

我试图执行以下操作：

找到有价值的单元格，让我们说＆＃34; Sam＆＃34;，在范围内（＆＃34; B17：B25＆＃34;）
偏移（0,5）.resize（8）.copy
找到数据行的日期值，并根据数据的日期将数据粘贴到范围（＆＃34; B4：M4＆＃34;）。
循环找到下一个。

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

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 loop 也会起作用：

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

找到具有值，偏移和复制范围的单元格，然后粘贴基础数据的日期，然后循环到findnext

2 个答案: