查找范圍內的文本，然后將下一個Activecell.offset（1,1）16個單元格復制到目標位置

Question

我的范圍是I13至I6076。 我從第一個I13單元格開始，並在Range（“ D12：D103333”）中找到一個匹配項。 如果在Col D中找到匹配項，則應該從Col D單元格偏移Activecell.offset（1,1），然后將接下來的16個單元格（垂直副本）復制到相應的I13行（水平粘貼）。 然后轉到I14，依此類推。 我創建了一個do while循環來查找Range（“ D12：D103333”）范圍內的單元格，但是如何偏移並復制接下來的16個單元格。 然后轉到第I列的下一個單元。任何幫助將不勝感激。 非常感謝。 代碼如下。

子Kantar（）

Dim Category As String
i As Integer

Range("I13").Select
Do While Not IsEmpty(ActiveCell)
    Category = ActiveCell.Value
    Range("D12:D103333").Find(What:=Category, MatchCase:=True).Select


ActiveCell.Offset(1, 0).Select
Loop

結束子

Answer 1

嘗試做這樣的事情：

1）一旦找到該單元格， activecell.offset(1,1)

2）從那里，使用您的activecell.address和activecell.address + 16作為范圍來做range.copy

3）將活動單元偏移到要粘貼的位置。

4）使用“轉置”粘貼“特殊”，將其水平轉置（使用宏記錄器向您展示不確定的方式）

5）向后偏移到原始單元格（坐標基於您最終的位置）

6）偏移1個單元格並繼續循環。 （您已經編碼了）

我會提供實際的代碼，但我不在PC上。 如果其他人沒有給您代碼，希望這些步驟仍然有用:)

Answer 2

首先，我要感謝Busse為我提供了獲得答案的合理步驟。 超級有幫助。 因此，我在下面復制我的代碼，這可能會幫助一些遇到類似問題的用戶。 謝謝：））

Sub Kantar2()

    Dim Category As String, i As Long, FinalRow As Long
    Dim Rng As Range, MyCell As Range

    Application.ScreenUpdating = False
    i = 10
    FinalRow = Cells(Rows.Count, 4).End(xlUp).Row
    Set Rng = Range("I13:I6086")
    For Each MyCell In Rng
        Category = MyCell.Value
        Range(Cells(i, 4), Cells(FinalRow, 4)).Find(What:=Category, MatchCase:=True).Select
        i = ActiveCell.Row
        ActiveCell.Offset(1, 1).Select
        Range(Cells(ActiveCell.Row, 5), Cells(ActiveCell.Row + 15, 5)).Copy
        MyCell.Offset(0, 1).PasteSpecial Transpose:=True
    Next MyCell
    Application.ScreenUpdating = True
End Sub