Consolideren werkbladen

[veenvlij]

Ik ben op zoek naar VBA code voor hetvolgende :
Ik wil data uit 2 werkbladen (uit hetzelfde excel document) consolideren gebaseerd op kolomnaam.
Zie voorbeeld bestand
Blad ‘Main’ dient verrijkt te worden met de data uit blad ‘Imported’ indien de kolomnaam overeenkomt met kolomnaam in ‘Main’
Op blad ‘Main’ zijn alle kolommen en rijen gevuld.
Heeft iemand hier een goede oplossing voor ?

M.vr.groet
veenvlij

 

[cow18]

Sub Consolideren()
    Set c = Sheets("imported").Range("A1").CurrentRegion             'je importgegevens
    sn0 = Application.Index(c, 1, 0)                                 'titelrij in array zetten
    sn1 = c.Offset(1).Resize(c.Rows.Count - 1)                       'de rest van de gegevens in 2e array zetten

    Set c = Sheets("MAin").Range("A1").CurrentRegion                 'je bereik in main
    sn2 = Application.Index(c, 1, 0)                                 'koprij van Main in array zetten

    For i = 1 To UBound(sn0, 2)                                      'al je titels van imported 1 per 1 aflopen
        j = Application.Match(sn0(1, i), sn2, 0)                     'zoek die titel in de koprij van main
        If IsNumeric(j) Then                                         'is ze numeriek, dan is ze gevonden, anders resulteerde dit in een fout
            c.Offset(c.Rows.Count, j - 1).Resize(UBound(sn1), 1).Value = Application.Index(sn1, 0, i)    'zet in de zoveelste kolom in 1 en zoveel rijen naar beneden, die ie kolom van import
        End If
    Next
End Sub

 

[HSV]

Ik was er ook al begonnen, maar kon het niet eerder afmaken.

Bijna dezelfde aanpak als Bart. :thumb:
Iets ingewikkelder, maar de lus voor het wegschrijven is korter.

Sub hsv()
 Dim sv, sv_2, sq, jj, j As Long
    sv = Sheets("imported").Cells(1).CurrentRegion
    sv_2 = Sheets("main").Cells(1).CurrentRegion
    sq = Split(Join(Application.Index(sv_2, 1, 0)))
    With Application
        sv = .Index(sv, Evaluate("row(1:" & UBound(sv) & ")"), Filter(.IfError(.Match(sq, .Index(sv, 1), 0), False), False, 0))
     For j = 1 To UBound(sv, 2)
       jj = .Match(sv(1, j), .Index(sv_2, 1, 0), 0)
        Sheets("main").Cells(Rows.Count, jj).End(xlUp).Offset(1).Resize(UBound(sv) - 1) = .Index(sv, Evaluate("row(2:" & UBound(sv) & ")"), j)
    Next j
 End With
End Sub

 

[cow18]

inderdaad, ook mooi, ik krijg die evaluate nooit lekker rond !
Dat is een tikkeltje te hoog gemikt voor mijn hersenen.

 

[HSV]

Dank je.

Ik moest eerst goed kijken naar je code, het leek veel op die van mij waar ik al aan begonnen was en jij nog niet gereageerd had.
Om de evaluatie rond te krijgen gaat bij mij ook regelmatig de meeste tijd mee gemoeid.

Zo had ik de eerste evaluatie op rij 2 laten beginnen i.p.v. op rij 1, en dan ga je pas denken hoe krijg ik nu de eerste waarde weer terug voor de lus.
Zulke dingetjes dus.

Ik heb de code iets aangepast door 'End With' naar onderen te plaatsen en de 'isnumeric' eruit te laten daar ik al de juiste waarden heb in de lus.

Leuke opgave.

 

[veenvlij]

Bart en Harry,

Dank jullie wel voor de oplosingen, beide werken uitstekend.
Met vriendelijke groet
Veenvlij

 

[snb]

Alternatief:

Sub M_snb()
   Blad2.Cells(1).CurrentRegion.Rows(1).Copy Blad2.Cells(Rows.Count, 2).End(xlUp).Offset(2, -1)
   Sheet1.Cells(1).Copy Sheet1.Cells(1, 30)
   Sheet1.Cells(2, 30) = "<>"""""
   
   With Blad2.Cells(Rows.Count, 1).End(xlUp).CurrentRegion.Rows(1)
        Sheet1.Cells(1).CurrentRegion.AdvancedFilter 2, Sheet1.Cells(1, 30).CurrentRegion, .Find(Sheet1.Cells(1, 1))
        Sheet1.Cells(1).CurrentRegion.AdvancedFilter 2, Sheet1.Cells(1, 30).CurrentRegion, .Find(Sheet1.Cells(1, 2))
        Sheet1.Cells(1).CurrentRegion.AdvancedFilter 2, Sheet1.Cells(1, 30).CurrentRegion, .Find(Sheet1.Cells(1, 3))
        .Offset(-1).Resize(2).Delete
    End With

   Sheet1.Cells(1, 30).CurrentRegion.Clear
End Sub