Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Поиск и подстановка соответсвующих значений с учетом 2 условий - через макрос.
 
#1
21.12.2017 12:40:36
Всем доброго дня!
Нужна Ваша помощь, не пойму как переделать макрос, что бы учитывался еще один параметр при заполнении таблицы.
Т.е. на Лист1 есть таблица куда подтягиваются значения из Лист2...
Сейчас они подставляются только по одному условия столбца "Номер заявки"... но необходимо еще учитывать второй параметр - это номер бланка. т.к. заявка может быть одна но бланки разные...
Подскажите что добавить и куда...
Изменено: a.i.mershik - 21.12.2017 12:41:45
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#2
21.12.2017 13:56:29
Макрос в стандартный модуль, находясь на Листе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
 
 
 
#3
21.12.2017 14:04:50
Kuzmich, класс спасибо,  а можно пояснения ..что бы понять где допустим поменять если условий будет больше 2...
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#4
21.12.2017 14:14:18
Сначала ищете все номера заявок, например 2500  
Код
 Set FoundCell = .Columns(1).Find(Cells(i, 2), , xlValues, xlWhole)
В строке, где нашли номер заявки, проверяете номер бланка  
Код
If .Cells(FoundCell.Row, 4) = Cells(i, 3) Then
 
 
 
#5
21.12.2017 14:17:33
Kuzmich, т.е. если мне рядом будет третье условие  то нужно будет еще одно If ? или его можно в это вставить через and??
Код
If .Cells(FoundCell.Row, 4) = Cells(i, 3) and .Cells(FoundCell.Row, 5) = Cells(i, 4) Then
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#6
21.12.2017 14:30:48
Код
and .Cells(FoundCell.Row, 5) = Cells(i, 4)
Зачем столбец Касса сравнивать со столбцом Время?
 
 
 
#7
21.12.2017 14:32:52
Kuzmich, это я образно))
что бы понять логику.
Так сказать сделать его более универсальным  и для решения не данной задачи а вообще.
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#8
21.12.2017 14:41:03
Цитата
сделать его более универсальным
Я бы в одном из столбцов сделал конкатенацию номера заявки и номера бланка и поиск
осуществлял по этому уникальному номеру
 
 
 
#9
21.12.2017 14:44:47
Kuzmich, ну да как вариант это с доп. столбцом....
я просто думаю  ее использовать для решения вопросов вместо приминения функций ВПР или ПОИСКПОЗ+ИНДЕКС или ПРОСМОТР.
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#10
21.12.2017 14:50:11
Еще вариант с массивами.
Код
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
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#11
21.12.2017 14:59:22
Цитата
думаю  ее использовать для решения вопросов
А автофильтр не подойдет?
 
 
 
Страницы: 1
Наверх