查找范围内的文本，然后将下一个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