Find a text in a range and copy the next Activecell.offset(1,1)16 cells to destination

Question

I have a range I13 to I6076. I am starting at first I13 cell and finding a match in Range("D12:D103333"). If it finds a match in Col D then it should offset Activecell.offset(1,1) from Col D cell and copy the next 16 cells(vertical copy) to corresponding I13 row(horizontal paste). and then move on to I14 and so on. I have created a do while loop to find the cells in the range Range("D12:D103333"), but how do I offset and copy the next 16 cells. and then go to next cell in col I. Any help would be greatly appreciated. Many Thanks. Code is below.

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

Try doing something like this:

1) Once the cell is found, activecell.offset(1,1)

2) From there, use your activecell.address and activecell.address + 16 as a range to do range.copy

3) Offset the active cell to where you want to paste.

4) Paste Special with transpose to transpose it horizontally (use macro recorder to show you how if you are unsure)

5) Offset back to original cell (coordinates based on where you end up)

6) Offset down 1 cell and continue the loop. (Which you already have coded)

I'd give actual code but I'm not at a PC. Hopefully these steps still help if someone else doesn't give you the code :)

Answer 2

Firstly I would like to Thank Busse for providing me the logical steps to get my answer. It was Super helpful. So I am copying my code below which might help several users with similar issues. Thanks:))

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