Консолидация данных из нескольких листов с несколькими строками заголовков VBA

Question

Заранее спасибо за вашу помощь.

У меня есть задача скопировать данные с двух листов на лист «Консолидация». Оба листа имеют одинаковые заголовки, но мне нужно сохранить только один набор этих заголовков.

До сих пор я пробовал несколько методов консолидации, но они либо копируют все, либо суммируют все числовые значения.

Когда я попытался преобразовать текст в заголовок, это позволило бы преобразовать только одну строку, возможно, есть другой способ, но я не смог его найти.

'код нижекопирует числа, если я буду таблицу с числами, но игнорирует строки

Dim ws As Worksheet
Dim sArray As Variant, i As Integer
ReDim sArray(1 To 1)

'---Make Array with Named Ranges to be Consolidated
For Each ws In ActiveWorkbook.Worksheets
    If ws.Visible And ws.Name <> "Consolidation" Then
        i = i + 1
        ReDim Preserve sArray(1 To i)
        sArray(i) = ws.UsedRange.Address(ReferenceStyle:=XlReferenceStyle.xlR1C1, external:=True)
    End If
Next ws
If i = 0 Then Exit Sub

'---Consolidate using the Array
Sheets("Consolidation").Range("A1").Consolidate Sources:=(sArray), _
    Function:=xlSum, TopRow:=False, LeftColumn:=False, CreateLinks:=False

Sheet1: https://imgur.com/a/S0h0iHv

Sheet2: https://imgur.com/a/S0h0iHv

Желаемый результат: https://imgur.com/a/kthyNPv

Еще раз спасибо всем за помощь.

Answer 1

Public Sub CopyRows() 
    Sheets("Sheet1").Select 
    ' Find the last row of data 
    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row 
    ' Loop through each row 
    For x = 2 To FinalRow 
        ' Decide if to copy based on column D 
        ThisValue = Cells(x, 4).Value 
        If ThisValue = "A" Then 
            Cells(x, 1).Resize(1, 33).Copy 
            Sheets("SheetA").Select 
            NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1 
            Cells(NextRow, 1).Select 
            ActiveSheet.Paste 
            Sheets("Sheet1").Select 
        ElseIf ThisValue = "B" Then 
            Cells(x, 1).Resize(1, 33).Copy 
            Sheets("SheetB").Select 
            NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1 
            Cells(NextRow, 1).Select 
            ActiveSheet.Paste 
            Sheets("Sheet1").Select 
        End If 
    Next x 
End Sub

Этот код помог решить проблему :-)