Форум по VBA и MS Office

Sub макрос()
   
    Dim sh_mat As Worksheet, sh_spravka As Worksheet
    Dim i As Long, lr As Long
   
   
    '1. Отключение монитора, чтобы ускорить макрос.
    Application.ScreenUpdating = False
   
    '2. Присваиваем имена листам, с которыми надо работать, чтобы по этим именам обращаться к листам.
    Set sh_mat = Worksheets("MaterialsNorms")
    Set sh_spravka = Worksheets("Справочник")
   
    '3. Удаление строк на листе "MaterialsNorms", у которых пусто в столбце 4.
    ' Поиск последней строки. Не должно быть скрытых строк, т.к. End не ищет в скрытых строках.
    lr = sh_mat.Cells(sh_mat.Rows.Count, 2).End(xlUp).row
    ' Удаление.
    For i = lr To 10 Step -1
        If sh_mat.Cells(i, 4).Value = "" Then
            sh_mat.Rows(i).Delete
        End If
    Next i
   
    '4. Заполнение столбца 6 на листе "MaterialsNorms".
    lr = sh_mat.Cells(sh_mat.Rows.Count, 4).End(xlUp).row
    For i = 10 To lr
        ' Для заполнения используется эксель-функция ВПР.
        sh_mat.Cells(i, 6).Value = _
            WorksheetFunction.VLookup(sh_mat.Cells(i, 4).Value, sh_spravka.Columns("A:B"), 2, 0)
    Next i
   
    '5. Вкл. монитора.
    Application.ScreenUpdating = True
   
    '6. Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

Sub macro()
   
    Dim sh_mats As Worksheet, sh_spravka As Worksheet
    Dim spr_rows As Collection, spr_data()
    Dim arr(), r As Long, lr As Long, i As Long
   
   
    '1. Отключение монитора для ускорения макроса.
        ' Это нужно для работы с эксель-листом. Для аксеса это не надо.
    Application.ScreenUpdating = False
   
    '2. Присваиваем листам имена "sh_mats" и "sh_spravka", чтобы удобно писать код.
    Set sh_mats = Worksheets("MaterialsNorms")
    Set sh_spravka = Worksheets("Справочник")
   
    '3. Запись информации из справки в элементы. В коллекции "spr_rows" будут D1 и номера строка, где
        ' находятся D1. В массиве "spr_data" будут данные из справки, которые надо вставить на лист-результат.
        ' Коллекция используется для ускорения макроса.
    '1) Поиск последней строки. End не работает со скрытыми строками.
    lr = sh_spravka.Cells(sh_spravka.Rows.Count, "A").End(xlUp).row
    '2) Запись данных в массив. С массивом макрос быстрее работает, чем с объектами.
    spr_data() = sh_spravka.Range("A1:D" & lr).Value
    '3) Создание коллекции.
    Set spr_rows = New Collection
    '4) Запись D1 и номеров строк в коллекцию.
    For i = 2 To UBound(spr_data, 1)
        ' В параметр "Key" у коллекции можно записать только тип String.
        spr_rows.Add Item:=i, key:=CStr(spr_data(i, 1))
    Next i
   
    '4. Запись данных на лист-результат.
    '1) Поиск последней строки. End не работает со скрытыми строками.
    lr = sh_mats.Cells(sh_mats.Rows.Count, "D").End(xlUp).row
    '2) Копирование столбцов D в массив, чтобы ускорить макрос.
    arr() = sh_mats.Range("D1:D" & lr)
    '3) Запись данных на лист-результат.
    For i = 10 To UBound(arr, 1)
        ' Если в столбце D не пусто.
        If arr(i, 1) <> "" Then
            ' Запись в переменную "r" номера строки из справки.
            r = spr_rows(CStr(arr(i, 1)))
            ' Запись данных на лист-результат.
            sh_mats.Cells(i, "F").Value = spr_data(r, 2)
            sh_mats.Cells(i, "I").Value = spr_data(r, 3)
            sh_mats.Cells(i, "K").Value = spr_data(r, 4)
        End If
    Next i
   
    '5. Вкл. монитора.
    Application.ScreenUpdating = True
   
    '6. Сообщение.
    MsgBox "Готово.", vbInformation
   
End Sub