Всем доброго дня! Нужна Ваша помощь, не пойму как переделать макрос, что бы учитывался еще один параметр при заполнении таблицы. Т.е. на Лист1 есть таблица куда подтягиваются значения из Лист2... Сейчас они подставляются только по одному условия столбца "Номер заявки"... но необходимо еще учитывать второй параметр - это номер бланка. т.к. заявка может быть одна но бланки разные... Подскажите что добавить и куда...
Макрос в стандартный модуль, находясь на Листе1 запустить макрос
Код
Sub iZajavkaNomer()
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim FAdr As String
iLastRow = [B6].End(xlDown).Row
Range("D7:F" & iLastRow).ClearContents
With Worksheets("Лист2")
For i = 7 To iLastRow
Set FoundCell = .Columns(1).Find(Cells(i, 2), , xlValues, xlWhole)
If Not FoundCell Is Nothing Then
FAdr = FoundCell.Address
Do
If .Cells(FoundCell.Row, 4) = Cells(i, 3) Then
Cells(i, 4) = .Cells(FoundCell.Row, 3) 'время
Cells(i, 5) = " н.п. " & .Cells(FoundCell.Row, 9) & ", р-н " & .Cells(FoundCell.Row, 10) _
& ", ул. " & .Cells(FoundCell.Row, 11) & " д. " & .Cells(FoundCell.Row, 12) _
& ", корп." & .Cells(FoundCell.Row, 13) & ", кв. " & .Cells(FoundCell.Row, 14) _
& ", эт. " & .Cells(FoundCell.Row, 15) 'адрес доставки
Cells(i, 6) = .Cells(FoundCell.Row, 17) 'описание
End If
Set FoundCell = .Columns(1).FindNext(FoundCell)
Loop While FoundCell.Address <> FAdr
End If
Next
End With
End Sub
Kuzmich, ну да как вариант это с доп. столбцом.... я просто думаю ее использовать для решения вопросов вместо приминения функций ВПР или ПОИСКПОЗ+ИНДЕКС или ПРОСМОТР.
Sub test()
Dim arr(), iarr(), larr()
Dim i&, j&, x&, lrow&, itxt$
lrow = Лист1.Range("b" & Rows.Count).End(xlUp).Row
arr = Лист1.Range("b7:f" & lrow).Value
iarr = Лист2.UsedRange.Value
larr = Array("н.п. ", ", р-н ", ", ул. ", " д. ", ", корп. ", ", кв. ", ", эт. ")
With CreateObject("scripting.dictionary")
For i = 1 To UBound(iarr)
itxt = "": itxt = Trim(iarr(i, 1)) & Trim(iarr(i, 4)): .Item(itxt) = i
Next i
For i = 1 To UBound(arr)
itxt = "": itxt = Trim(arr(i, 1)) & Trim(arr(i, 2))
If .exists(itxt) Then
j = .Item(itxt)
arr(i, 3) = iarr(j, 3)
itxt = ""
For x = 0 To UBound(larr): itxt = itxt & larr(x) & iarr(j, x + 9): Next x
arr(i, 4) = itxt
arr(i, 5) = iarr(j, 17)
End If
Next i
End With
Лист1.Range("b7").Resize(UBound(arr), UBound(arr, 2)).Value = arr
End Sub
"Все гениальное просто, а все простое гениально!!!"