Это может быть не красиво и не масштабируемо, но, поскольку я не уверен, чего именно вы пытаетесь достичь в долгосрочной перспективе, вот что должно сработать.
Во-первых, строка For Each cell In sht.Range("A20:A34,D20:D34,G20:G34").Cells
не соответствует ячейкам, используемым в вашем примере, поэтому я изменил это на:
For Each cell In sht.Range("A20:A34,E20:E34,I20:I34").Cells
Затем я перехватил переменную tmp в конце, потому что она больше не используется, и установил ее, чтобы найти последнюю ячейку столбца, в которой было найдено совпадение, например:
Set tmp = sht.Cells(Cells(Rows.Count, cell.Column).End(xlUp).Row, cell.Column)
Затем нам нужно указать новые поля и убедиться, что мы заполняем их только один раз. Вы можете сделать это, проверив, является ли первый пустым, или со счетчиком. В любом случае, он будет работать правильно только до тех пор, пока вы найдете менее 4 совпадений.
Конечный результат был таким, измените по мере необходимости;
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