Форум по VBA, Excel и Word

VBA, Excel => VBA, макросы в Excel => Тема начата: Jk от 25 ноября 2019, 08:09

Название: Excel VBA Макросы: Поиск значения в одном столбце по критерию в другом столбце и вынос всех значений удовлетворяющих условию в отдельную ячейку.
Отправлено: Jk от 25 ноября 2019, 08:09
Возможно ли решить эту задачку с помощью макроса?
Поиск значения в одном столбце по критерию в другом столбце и вынос всех значений удовлетворяющих условию в отдельную ячейку. Если это важно: все значения текстовые.

[вложение удалено администратором]
Название: Re: Excel VBA Макросы: Поиск значения в одном столбце по критерию в другом столбце и вынос всех значений удовлетворяющих условию в отдельную ячейку.
Отправлено: Администратор от 25 ноября 2019, 12:11
Вверху модуля вставьте эти строки:
Option Explicit
Option Compare Text
Option Base 1

Макрос
Sub Макрос()

    Dim компании(), что(), где(), рез()
    Dim сборник As String
    Dim lr As Long, i As Long, ii As Long
   
   
    '1. Копируем данные из столбцов в vba-массивы: с vba-массивами макрос
        ' быстрее работает, чем с эксель-ячейками.
    ' Поиск последней строки.
        ' End не ищет в скрытых строках.
    lr = Cells(Rows.Count, "E").End(xlUp).Row
    ' Копирование столбца в массив.
    что() = Range("E4:E" & lr).Value
    lr = Cells(Rows.Count, "G").End(xlUp).Row
    где() = Range("G4:G" & lr).Value
    компании() = Range("A4:A" & lr).Value
   
    '2. Создание ячеек в массиве-результате: сначала в него запишутся данные,
        ' а затем он будет вставлена на лист. Возможно это ускорит макрос.
        ' Также это может быть упростит чтение кода.
    ReDim res(UBound(что), 1)
   
    '3. Заполнение массива "res".
    ' Движение по строкам массива "что".
    For i = 1 To UBound(что)
   
        '1) Если в ячейке троеточие, то переходим на следующую строку.
        If что(i, 1) = "---" Then
            GoTo СледСтрока
        End If
       
        '2) Сброс переменной от предыдущего витка цикла.
        сборник = ""
       
        '3) Движение по строкам массива "где".
        For ii = 1 To UBound(где)
            ' Если данные в двух ячейках одинаковые, то запись данных в переменную "сборник".
                ' Данные записываются в конец переменной "сборник".
            If где(ii, 1) = что(i, 1) Then
                сборник = сборник & компании(ii, 1) & Chr(10)
            End If
        Next ii
       
        '4) Копирование данных из переменной "сборник" в массив "res".
        ' Если в переменной есть данные.
        If сборник <> "" Then
            ' Удаление с конца заранее вставленного символа "новая строка".
            сборник = Left(сборник, Len(сборник) - 1)
            ' Запись данных в массив.
            res(i, 1) = сборник
        End If
       
СледСтрока:
    Next i
   
    '4. Вставка массива на лист.
    Range("K4").Resize(UBound(res)).Value = res()
   
    '5. Сообщение.
    MsgBox "Готово.", vbInformation
   
End Sub
[свернуть]
Название: Re: Excel VBA Макросы: Поиск значения в одном столбце по критерию в другом столбце и вынос всех значений удовлетворяющих условию в отдельную ячейку.
Отправлено: Jk от 25 ноября 2019, 12:25
Огромное Вам спасибо!