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

[sersh1]

Спасибо, но к сожалению мне нужно именно в том виде заполненное.

[sersh1]

вот тут в паримере как должно получиться.

[Hugo121]

Ааа, так тут другое совсем нужно....
Тот код забудьте. Т.е. запомните, но для другой задачи

P.S. Хотя можно и сюда приспособить (раз уж есть, чтоб другой не писать, хотя можно сделать и совершенно иначе):

Sub tt()
Dim a, oDict As Object, i&, ii&, temp$, kk

a = [a3].CurrentRegion.Value
Set oDict = CreateObject("Scripting.Dictionary")
oDict.CompareMode = vbTextCompare

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

Dim startRow&
startRow = 13

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

End Sub

Или так, покороче:

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

a = [a3].CurrentRegion.Columns(1).Value
b = [a3].CurrentRegion.Columns(2).Value

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

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

Dim startRow&
startRow = 13

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

End Sub

[sersh1]

спасибо, взял второй код, но немного не получается, т.к. у меня могут быть заполнены города и фио от строки 3 до 9, причем в них стоят формулы, и поэтому он мне делает с промежутком в несколько строк между собой, и еще вопрос а если мне нужно взять не колонку в, а другую колонку где ажрес ячейки с ФИО? в примере то что получается пытался исправить код сам не получается

[sersh1]

извиняюсь что сразу в примере не поставил формулы я новичок, не знал что это так важно

[sersh1]

пример как получилось

[Hugo121]

Если формулы - тогда CurrentRegion не подходит.
Нужно другим способом выявить нужный диапазон, получить из него два массива данных, а потом уже по схеме. Но в итоге вместо UBound(a) вероятно нужно брать UBound() того массива, который длиннее (с CurrentRegion они одинаковы по высоте).
Я сейчас доделывать не буду - что-то приболел... подключайтесь, кто в теме...

[sersh1]

Прошу Вас помогите, пожалуйста, как можно решить данную задачу, необходимо что бы заполнялась таблица, в колонку а и в могут быть внесено до 7 городов и фио, нужно выбрать по всем городам эти фио, далее таблица макросом будет заполняться другими данными.
в колонках а и б стоят формулы....в примере приведено как должно получиться.
Очень надеюсь на вашу помощь....

[Hugo121]

Сильно код не менял, но повозился с диапазонами - ничего лучше не придумал, чем так, перебором.
Зачем у Вас там пробелы формулами ставятся?!!
Ну да ладно, пусть...

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, 2)))
    b = Range("B3", Range("B" & 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), 1) = oDict.Item(kk)
        startRow = startRow + UBound(b)
    Next

End Sub

Код повесил на кнопку.

Если фамилии не в B, то меняйте тут:

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

Цель - получить массив с нужными данными, без пустых значений внизу.

[sersh1]

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

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, 2)))

b = Range("B3", Range("B" & x - 1)).Value

x = 2
Do
x = x + 1
Loop While Len(Trim(Cells(x, 2)))

d = Range("C3", 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), 1) = oDict.Item(kk)
Cells(startRow, 3).Resize(UBound(d), 1) = oDict.Item(kk)
startRow = startRow + UBound(b)
Next

End Sub