Question

我有一个范围I13到I6076。我首先开始I13单元格并在Range中找到匹配（“D12：D103333”）。如果它在Col D中找到匹配，那么它应该从Col D单元偏移Activecell.offset（1,1）并将接下来的16个单元（垂直副本）复制到相应的I13行（水平粘贴）。然后转到I14，依此类推。我创建了一个do while循环来查找范围Range（“D12：D103333”）中的单元格，但是如何偏移和复制接下来的16个单元格。然后转到第一组的下一个单元格。任何帮助将不胜感激。非常感谢。代码如下。

Sub 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

End Sub

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

查找范围内的文本并将下一个Activecell.offset（1,1）16单元格复制到目标

2 个答案: