Loop through file and consolidate specific columns

[SjofaaSj]

Het rapport dat ik wekelijks krijg aangeleverd bevat meerdere sheets, eentje per collectie.
Van al deze sheets moet ik de inhoud van 4 kolommen kopiëren naar één enkele 'summary'-sheet

Maar nagenoeg alles is variabel
- het aantal sheets
- het aantal rijen per sheet
- de volgorde van de kolommen

Het enige wat vaststaat zijn de kolomtitels die ik eruit moet halen, al komen deze niet noodzakelijk in elke sheet voor.

Het is telkens ongelooflijk saai en tijdrovend werk om die summary te maken, dus wil ik VBA inschakelen
Mijn idee is om een CONSO sheet aan te maken, om daarin de gegevens te plakken van de verschillende sheets.

Hieronder de code die ik al heb
- maakt een CONSo sheet aan
- zet daarin de titels die ik nodig heb
- doet een loop over de verschillende sheets
Maar ik zit vast met het volgende
- check de kolomnaam of deze voorkomt in de opgegeven array
- indien die er niet inzit, mag de kolom verborgen worden
- indien die overeenstemt met een waarde uit de array moet hij de data overzetten naar de CONSO sheet

Kan iemand me verder helpen aub.

Sub ConsolidateSpecificColumns()
    Dim wks As Worksheet
    Dim myShtName As String
    Dim ShowMe As Variant
    Dim Row_ColCount As Long
    Dim Col_RowCount As Long
    Dim ColStart As Long, ColLast As Long, RowLast As Long
'prm
    myShtName = "CONSO"
    ShowMe = Array("ARTNR", "ARTNR CVR", "PRICE", "PRICE CVR")
    Row_ColCount = 1 'row on which column headers must be counted/hidden
    ColStart = 2 'first column to check
'check
   On Error Resume Next
   Sheets(myShtName).Select
    With ActiveWindow
        .ScrollRow = 1
        .ScrollColumn = 1
    End With
    If MsgBox("Update/Create " & mySht & " sheet?" & vbLf & _
            "Existing sheet will be deleted", _
            vbYesNo + vbQuestion, "JDW") <> vbYes Then Exit Sub
    'insert CONSO sheet
    Application.DisplayAlerts = False
    Sheets(mySht).Delete
    Sheets.Add(Before:=Sheets(1)).Name = mySht
    Cells(1, 1).Value = "SHEETNAME"
    Cells(1, 2).Value = "ARTNR"
    Cells(1, 3).Value = "PRICE"
    Cells(1, 4).Value = "ARTNR CVR"
    Cells(1, 5).Value = "PRICE CVR"
    Application.DisplayAlerts = True
'run
    For Each wks In ActiveWorkbook.Worksheets
        'reset
        Cells.EntireColumn.Hidden = False 'unhide all columns
        'column count
        With wks
            ColLast = .Cells(Row_ColCount, .Columns.Count).End(xlToLeft).Column
            RowLast = .Cells(.Rows.Count, Col_RowCount).End(xlUp).Row
        End With
        'loop
        For i = ColStart To ColLast
            If Cells(Row_ColCount, i).Value <> ShowMe Then 'if column title is not in array
                Cells(Row_ColCount, i).EntireColumn.Columns.Group 'hide columns where title is not in array
            Else
                Range(Cells(Row_ColCount + 1, i), Cells(RowLast, i)).Copy
                'copy to CONSO sheet where first column is the sheetname and this goes into the into the appropriate column
            End If
        Next i
    Next wks
    Sheets(mySht).Activate
End Sub

 

[snb]

Gebruik advanced filter en voeg voorbeeldbestanden bij.

 

[cow18]

is inderdaad de snelste manier.