Es ist vielleicht nicht hübsch oder skalierbar, aber da ich nicht genau weiß, was Sie auf lange Sicht erreichen wollen, sollte hier etwas funktionieren.
Erstens For Each cell In sht.Range("A20:A34,D20:D34,G20:G34").Cells
stimmt die Zeile nicht mit den in Ihrem Beispiel verwendeten Zellen überein, daher habe ich Folgendes geändert:
For Each cell In sht.Range("A20:A34,E20:E34,I20:I34").Cells
Dann habe ich die tmp-Variable am Ende entführt, weil sie nicht mehr verwendet wird, und habe sie so eingestellt, dass sie die letzte Zelle der Spalte findet, in der sie eine Übereinstimmung gefunden hat, wie folgt:
Set tmp = sht.Cells(Cells(Rows.Count, cell.Column).End(xlUp).Row, cell.Column)
Dann müssen wir die neuen Felder angeben und sicherstellen, dass wir nur jedes Mal füllen. Sie können dies tun, indem Sie prüfen, ob der erste leer ist oder einen Zähler hat. So oder so funktioniert es nur, wenn Sie weniger als 4 Übereinstimmungen finden.
Das Endergebnis war dies, ändern Sie es nach Bedarf.
Sub do_it() Dim sht As Worksheet, n As String, cell, num, tmp, rngDest As Range, i As Integer Set sht = ActiveSheet n = sht.Range("A1").Value i = 0 For Each cell In sht.Range("A20:A34,E20:E34,I20:I34").Cells tmp = cell.Offset(0, 1).Value If cell.Value = n And tmp Like "*#-#*" Then 'get the first number num = CLng(Trim(Split(tmp, "-")(0))) 'find the next empty cell in the appropriate row Set rngDest = sht.Cells(num, sht.Columns.Count).End(xlToLeft).Offset(0, 1) 'make sure not to add before col L If rngDest.Column < 12 Then Set rngDest = sht.Cells(num, 12) cell.Offset(0, 1).Copy rngDest ' This is getting the next number in A/E/I---- Set tmp = cell.Offset(1, 0) ' This is filling up B17 - F18 in order until filled If sht.Range("B17").Value = "" Then sht.Range("C17").Value = cell.Offset(0, 1).Value sht.Range("B17").Value = tmp.Value ElseIf sht.Range("B18").Value = "" Then sht.Range("C18").Value = cell.Offset(0, 1).Value sht.Range("B18").Value = tmp.Value ElseIf sht.Range("E17").Value = "" Then sht.Range("F17").Value = cell.Offset(0, 1).Value sht.Range("E17").Value = tmp.Value ElseIf sht.Range("E18").Value = "" Then sht.Range("F18").Value = cell.Offset(0, 1).Value sht.Range("E18").Value = tmp.Value End If '---- This clears the BCD/FGH/JKL columns after using the value ---- 'cell.Offset(0, 1).Resize(, 3).Value = "" End If Next cell End Sub