Suchen Sie einen Text in einem Bereich und kopieren Sie die nächste Activecell.offset (1,1) 16 Zellen zum Ziel

Question

Ich habe einen Bereich von I13 bis I6076. Ich beginne mit der ersten Zelle von I13 und finde eine Übereinstimmung in Range ("D12: D103333"). Wenn es eine Übereinstimmung in Col D findet, sollte es Activecell.offset (1,1) von Col D-Zelle versetzen und die nächsten 16 Zellen (vertikale Kopie) in die entsprechende I13-Zeile kopieren (horizontale Paste). und dann weiter zu I14 und so weiter. Ich habe eine do while-Schleife erstellt, um die Zellen im Bereich Range zu finden ("D12: D103333"), aber wie versetze ich und kopiere die nächsten 16 Zellen. und dann zur nächsten Zelle in Spalte I gehen. Jede Hilfe würde sehr geschätzt werden. Danke vielmals. Code ist unten.

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

Probieren Sie etwas wie dies zu tun:

1) Sobald die Zelle gefunden wird, activecell.offset(1,1)

2) Von dort Verwendung Ihre activecell.address und activecell.address + 16 als ein Bereich zu tun range.copy

3) Versetzen Sie die aktive Zelle an die Stelle, an der Sie einfügen möchten.

4) einfügen mit transponieren es horizontal zu transponieren (verwenden Sie Makro-Recorder, wie Sie zeigen, wenn Sie sich nicht sicher sind)

5) Offset zurück zur ursprünglichen Zelle (Koordinaten auf, wo Sie am Ende)

6) Versetzen Sie 1 Zelle nach unten und fahren Sie mit der Schleife fort. (Was Sie bereits codiert haben)

Ich würde tatsächlichen Code geben, aber ich bin nicht an einem PC. Hoffentlich helfen diese Schritte noch, wenn jemand anderes Ihnen den Code nicht gibt :)

Answer 2

Zuerst möchte ich Danke Busse dafür, mir die logischen Schritte zu geben, meine Antwort zu erhalten. Es war super hilfreich. Also kopiere ich meinen Code unten, der einigen Benutzern mit ähnlichen Problemen helfen könnte. Danke :))

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