Страницы: 1
RSS
Макрос на выборку данных из таблицы с дальнейшей подстановкой в строку рядом с критерием
 
Добрый день.
Помогите, пожалуйста, создать макрос. Задача следующая - есть таблица "А" со списком контрагентов и таблица "Б" со списком контрагентов и договоров с ними. Необходимо из таблицы "Б", согласно критерию из "А" выбрать все договора и подставить их в строку рядом с критерием. Пример прикрепляю
Заранее спасибо за помощь.  
 
Цитата
создать макрос.
Код
Sub Kontragent_Dogovor()
Dim iLastRow As Long
Dim i As Long
Dim Kontragent As String
Dim FoundKontragent As Range
Dim FirstAdres As String
Dim j As Integer
  iLastRow = Cells(Rows.Count, "F").End(xlUp).Row
    Range("G3:J" & iLastRow).ClearContents
  For i = 3 To iLastRow
    Kontragent = Cells(i, "F")
Set FoundKontragent = Columns(1).Find(Kontragent, , xlValues, xlWhole)
    If Not FoundKontragent Is Nothing Then     'нашли
        FirstAdres = FoundKontragent.Address   'адрес первого вхождения
          j = 7
        Do
            Cells(i, j) = FoundKontragent.Offset(, 1)
          Set FoundKontragent = Columns(1).FindNext(FoundKontragent)
            j = j + 1
        Loop While FoundKontragent.Address <> FirstAdres
    End If
  Next
End Sub
 
Kuzmich, ОГРОМНОЕ СПАСИБО ))))
все работает. вы сэкономили мне кучу времени и сил !!!
 
ну, и я раз уже написал. Только удалите в вашем файле Таблица А и Таблица Б (всю первую строку удалите из вашего примера)
Код
Sub Макрос1()
Dim LastRow As Long, arrData, arrUniqueUsers, i As Long, n As Long
    
    LastRow = Cells(Rows.Count, "F").End(xlUp).Row
    If LastRow > 1 Then
        Range("F1").CurrentRegion.Clear 'удаляем всё рядом с ячейкой F1
    End If
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("F1"), Unique:=True
    LastRow = Cells(Rows.Count, "F").End(xlUp).Row
    arrUniqueUsers = Range("F1:F" & LastRow)
    arrData = Range("A1").CurrentRegion
    
    For i = 2 To UBound(arrUniqueUsers)
        For n = 2 To UBound(arrData)
            If arrData(n, 1) = arrUniqueUsers(i, 1) Then
                Cells(i, Cells(i, Columns.Count).End(xlToLeft).Column + 1) = arrData(n, 2)
                Cells(1, Cells(i, Columns.Count).End(xlToLeft).Column) = "Договор"
            End If
        Next n
    Next i
    Range("F1").CurrentRegion.Borders.LineStyle = 1
    MsgBox "Таблица создана!", vbInformation, "Конец"
End Sub
Изменено: New - 25.11.2020 18:36:45
 
New, спасибо. попробую и ваш макрос )))
Страницы: 1
Наверх