Как сделать что бы макрос переходил к следующему циклу

[nilem]

А если так:

Sub ertert()
Dim i&, j&, k&, x, y(), s$
x = [a3].CurrentRegion.Value
ReDim y(1 To UBound(x) ^ 2, 1 To 3)

For i = 1 To UBound(x)
    If Len(Trim(x(i, 1))) Then
        s = x(i, 1)
        For j = 1 To UBound(x)
            If Len(Trim(x(j, 2))) Then
                k = k + 1: y(k, 1) = s: y(k, 2) = x(j, 2): y(k, 3) = x(j, 3)
            Else
                Exit For
            End If
        Next j
    Else
        Exit For
    End If
Next i

[a13:c13].Resize(k).Value = y
End Sub

[alex77755]

А если просто:

 Sub Города()
 Dim G
 Dim F
 G = 3
 F = 3
Do While Cells(G, 1).Value <> " "
Cells(Cells(Rows.Count, 2).End(xlUp).Row + 1, 1).Value = Cells(G, 1).Value
   Do While Cells(F, 2).Value <> " "
    Cells(Cells(Rows.Count, 2).End(xlUp).Row + 1, 2).Value = Cells(F, 2).Value
    Cells(Cells(Rows.Count, 2).End(xlUp).Row, 3).Value = Cells(F, 3).Value
    F = F + 1
   Loop
 F = 3
G = G + 1
Loop
 End Sub

[Hugo121]

Мой вариант на 3 столбца почти ничем не отличается от варианта на 2 - т.к. второй и третий столбец - это одно целое, то просто расширил второй массив:

Sub ttt()
    Dim a, oDict As Object, i&, temp$, kk
    Dim x&

    x = 2
    Do
        x = x + 1
    Loop While Len(Trim(Cells(x, 1)))
    a = Range("A3", Range("A" & x - 1)).Value

    x = 2
    Do
        x = x + 1
    Loop While Len(Trim(Cells(x, 3)))
    b = Range("B3", Range("C" & x - 1)).Value

    Set oDict = CreateObject("Scripting.Dictionary")
    oDict.CompareMode = vbTextCompare

    For i = 1 To UBound(a)
        temp = a(i, 1)
        If Not oDict.Exists(temp) Then
            oDict.Add temp, b
        End If
    Next

    Dim startRow&
    startRow = 13

    For Each kk In oDict.keys
        Cells(startRow, 1).Resize(UBound(b), 1) = kk
        Cells(startRow, 2).Resize(UBound(b), 2) = oDict.Item(kk)
        startRow = startRow + UBound(b)
    Next

End Sub

Николай, у тебя с новым примером работает не так, как заказывали...
да и у Алекса тоже...

Вообще-то конечно тут завязано на много условий, которые могут быть вдруг нарушены - например, если для моего кода будет пропуск в адресах - то всё, что ниже, пропадёт, да вообще ерунда получается.
Думаю, нужно использовать всё же currentregion, но для этого сперва скопировать всё как значения на другой новый лист, там убить ненужные пробелы в ячейках (ну вот нафига они нужны?), взять currentregion и с ним уже работать.

[nilem]

Сообщение от Hugo121

... с новым примером работает не так, как заказывали...

Адрес без фамилии тоже нужен? Тогда так:

Sub ertert()
Dim i&, j&, k&, x, y(), s$: x = [a3].CurrentRegion.Value
ReDim y(1 To UBound(x) ^ 2, 1 To 3): i = 1
Do While Len(x(i, 1)) > 1
    s = x(i, 1): j = 1
    Do While Len(x(j, 2)) > 1 Or Len(x(j, 3)) > 1
        k = k + 1: y(k, 1) = s: y(k, 2) = x(j, 2): y(k, 3) = x(j, 3): j = j + 1
    Loop: i = i + 1
Loop: [a13:c13].Resize(k).Value = y
End Sub

[sersh1]

Большое всем спасибо, у меня все получилось...

[sersh1]

у меня снова появился вопрос, далее мне нужно будет заполнять следующие колонки с помощью формул притягивания и вычисления из других листов, как сделать так что бы формулы вносились только в те ячейки по которым стоят данные в первых трех столбцах?
если первые три столбца пусты то что бы ничего не вносилось?

[nilem]

Например:
=ЕСЛИ(СЧЁТЗ(A13:C13)=3;ВПР(B13;Лист 2!$B$5:$E$15;4;0);"")

Только пришлось добавить Trim

[sersh1]

Спасибо, но мне нужно что бы именно макросом проставлялась формула везде где есть адрес доставки, нужно макросом именно потому что каждый раз размер таблицы по строкам может быть разный