範囲内のテキストを検索し、次のActivecell.offset（1,1）16セルを宛先にコピーします。

Question

範囲はI13〜I6076です。私は最初のI13細胞から始まり、Range（ "D12：D103333"）のマッチを見つける。 Col Dで一致するものが見つかると、ColcellからOffset（1,1）のActivecell.offsetをオフセットし、次の16個のセル（垂直コピー）を対応するI13行（水平貼り付け）にコピーする必要があります。その後、I14に移動します。 Range（ "D12：D103333"）の範囲のセルを見つけるためにdo whileループを作成しましたが、次の16個のセルをどのようにオフセットしてコピーしますか？次に列1の次のセルに移動してください。 何か助けていただければ幸いです。どうもありがとう。コードは以下のとおりです。

サブカンター（）

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

私は私の答えを得る論理的なステップを提供してくれてありがとうございます。それはスーパーに役立った。だから、以下のコードをコピーして、同様の問題を抱える複数のユーザーに役立つかもしれません。ありがとう:)

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