макрос для таблицы

[orlovya]

Добрый день,товарищи.Встала задача.
есть лист экселя с таблицой вида
___________
номер|улица|
-------------
18311 |адрес1
23321 |адрес2
18311 |
данные в таблице повторяются.Необходимо заполнить все строки адрес - улица соответственно. В примере у нас первая строка имеет номер 18311 и адрес 1. Третья строка имее тот же номер,но значение адреса не имеет(ячейка пустая). Необходимо заполнить все строки с одинаковыми номерами в ячейках соответствующими значениями адреса.Как это реализовать в VB?

[doober]

Как это реализовать в VB?

Прикрепить пример файла для проверки будущего макроса
Номера и названия дайте как в оригинале

[EducatedFool]

Попробуйте такой вариант:



Вот весь макрос:

Sub test()
    Dim cell As Range, ra As Range: Application.ScreenUpdating = False
    Dim coll As New Collection: On Error Resume Next
    Set ra = Range([A2], Range("A" & Rows.Count).End(xlUp))
    
    For Each cell In ra.Cells
        If Len(cell.Next) > 0 Then coll.Add Trim(cell.Next), CStr(cell)
    Next cell
    
    For Each cell In ra.Cells
        If Len(cell.Next) = 0 And Len(cell) > 0 Then cell.Next = coll(CStr(cell))
    Next cell
End Sub

[orlovya]

Вот образец файла,неудобно конечно просить сделать за меня,но времени на изучение просто нет.Если вам не трудно,буду очень благодарен.
Смысл в том,что в файле очень много строк. Данные в строке индекс(номера) повторяются на протяжении всего файла.Необходимо заполнить ячейку справа от индекса значением адреса.Значение адреса ранее уже сопоставлено с индексом.Т.е скопировать значение адреса во все ячейки с таким же индексом.

[orlovya]

макрос,предложенный EducatedFool работает,но только для примера который приводил выше.Если вы немного прольете свет на логику программного кода,то я попробую доделать его самостоятельно.

[alex77755]

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

Даже в коротком вашем примере индексу 18403 Записаны разные адреса. Брать первый?

[alex77755]

Ещё вариант:

Public Sub ZAP()
    Dim i, K
    Dim Dict As Object
 K = Columns(1).Rows(65536).End(xlUp).Row
Set Dict = CreateObject("Scripting.Dictionary")
With Dict
    For i = 2 To K
        If Not .Exists(Cells(i, 6).Value) And Cells(i, 7) <> Empty Then
          .Add Cells(i, 6).Value, Cells(i, 7).Value
       ElseIf .Exists(Cells(i, 6).Value) And Cells(i, 7) = Empty Then
         Cells(i, 7).Value = .Item(Cells(i, 6).Value)
        End If
    Next i
End With
End Sub

Если строк очень много и заметна малая скорость обработки - можно впихнуть всё в массив, обработать и вывалить на лист уже готовый вариант

[alex77755]

Через массив будет работать значительно быстрей

Public Sub ZAP()
Dim M()
    Dim i, K
    Dim Dict As Object
 K = Columns(1).Rows(65536).End(xlUp).Row
 M = Range(Cells(2, 6), Cells(K, 7)).Value
 
Set Dict = CreateObject("Scripting.Dictionary")
With Dict
    For i = 1 To K - 1
       If Not .Exists(M(i, 1)) And M(i, 2) <> Empty Then
          .Add M(i, 1), M(i, 2)
       ElseIf .Exists(M(i, 1)) And M(i, 2) = Empty Then
         M(i, 2) = .Item(M(i, 1))
        End If
    Next i
End With
Range(Cells(2, 6), Cells(K, 7)).Value = M
End Sub

[EducatedFool]

Код с комментариями:

Sub test()
    Dim cell As Range, ra As Range
    Dim coll As New Collection    ' создаём новую (пустую) коллекцию для пар АДРЕС - ИНДЕКС
    On Error Resume Next    ' не останавливаемся при ошибках (повторных индексах)
    Application.ScreenUpdating = False    ' отключаем перерисовку экрана

    ' диапазон для обработки - с ячейки A2 до последней заполненной в столбце А
    Set ra = Range([A2], Range("A" & Rows.Count).End(xlUp))
    ' перебираем все ячейки в диапазон RA, преобразовывая их в нормальные даты
    For Each cell In ra.Cells
        cell.NumberFormat = "m/d/yyyy h:mm"    ' меняем формат ячейки
        cell = CDate(Replace(cell, ",", "."))    ' меняем запятые на точки
    Next cell

    Set ra = ra.Offset(, 5)    ' смещаем диапазон RA на 5 столбцов вправо
    ' теперь он ссылается на ячейки столбца F (где у нас индексы)

    For Each cell In ra.Cells    ' перебираем все ячейки в диапазон RA (индексы)
        ' если ячейка справа (АДРЕС) непустая (длина текста больше нуля)
        ' то добавляем в коллекцию набор АДРЕС - ИНДЕКС
        If Len(cell.Next) > 0 Then coll.Add Trim(cell.Next), CStr(cell)
    Next cell

    ' итак, для всех адресов мы запомнили индексы
    ' теперь пишем адреса там, где их нет
    For Each cell In ra.Cells    ' перебираем все ячейки в диапазон RA (индексы)
        ' если ячейка справа (АДРЕС) ПУСТАЯ (длина текста равна нулю)
        ' то вылучаем из коллекции соответствующий данному индексу адрес
        If Len(cell.Next) = 0 And Len(cell) > 0 Then cell.Next = coll(CStr(cell))
    Next cell
End Sub

Пример в файле: http://excelvba.ru/XL_Files/Sample__...__23-05-14.zip

[Aent]

EducatedFool, давно хотел заметить по поводу часто употребляемой вами
конструкции вида

 Set ra = Range([A2], Range("A" & Rows.Count).End(xlUp))

В общем случае (а точнее когда последней заполненной строкой в таблице
будет строка Rows.Count ) она к сожалению неверна.
К своему удивлению, за последний месяц трижды столкнулся у разных клиентов
с данными в 65536 строке в Excel 2003...
Особенно это характерно для обработчиков всяческих реестров.
Часто люди переносят лист из Excel 2007-2010 в Excel 2003 c разбивкой по листам 2003 с учётом
ограничения на максимальное число строк.
Теперь после получения индекса строки по .End(xlUp).Row всегда проверяю, что
нижележащая ячейка пустая