Блог

У меня есть задание, в котором у меня есть два листа. У меня есть значения в первом столбце первого листа, давайте назовем это списком. Мне нужно скопировать все строки со второго листа на вновь созданный лист, содержащий любое из заданных значений списка в первом столбце. Для каждого значения в первом столбце второго листа существует несколько вхождений. Кто-нибудь может мне помочь, пожалуйста? Я боюсь, что формулы здесь не сработают.

Первый лист:

второй лист:

Создайте отчет (Поиск с совпадением)

• Следующее является промежуточным, не столь эффективным решением. Он попытается сопоставить каждое значение в столбце A ( sCol ) исходного рабочего листа с каждым значением в столбце A ( lCol ) рабочего листа поиска. При совпадении текущая ячейка ( sCell ) на Исходном листе будет добавлена (объединена) в Объединенный диапазон ( crg ). Наконец, все строки соответствующих ячеек (Объединенного диапазона) будут скопированы на целевой лист.
• Предполагается, что данные (таблицы) во всех листах начинаются с ячейки A1 и имеют одну строку заголовков.
• Отрегулируйте значения в разделе константы.

 Option Explicit

Sub createReport()
    
    ' Lookup
    Const lName As String = "Sheet1"
    Const lCol As Long = 1
    ' Source
    Const sName As String = "Sheet2"
    Const sCol As Long = 1
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim lrg As Range ' Lookup Range
    With wb.Worksheets(lName).Range("A1").CurrentRegion.Columns(lCol)
        Set lrg = .Resize(.Rows.Count - 1).Offset(1)
        'Debug.Print lrg.Address
    End With
    
    Dim crg As Range ' Combined Range
    Dim srg As Range ' Source Lookup Range
    With wb.Worksheets(sName).Range("A1").CurrentRegion
        Set crg = .Cells(1) ' Headers
        'Debug.Print crg.Address
        Set srg = .Columns(sCol).Resize(.Rows.Count - 1).Offset(1)
        'Debug.Print srg.Address
    End With
    
    Dim sCell As Range ' Current cell in Source Lookup Range
    For Each sCell In srg.Cells
        If IsNumeric(Application.Match(sCell.Value, lrg, 0)) Then
            Set crg = Union(crg, sCell)
            'Debug.Print crg.Address
        End If
    Next sCell
    
    Dim dCell As Range ' Destination First Cell (Range)
    Set dCell = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Range("A1")
    
    crg.EntireRow.Copy dCell

End Sub