kolommen kopieren van verschillende tabbladen naar 1 tabblad

[KeveinM]

In tabblad 4 zouden de gegevens moeten geplakt worden van de corresponderende kolommen op tabblad 1 .2 en 3

De plaats van de kolommen verschilt van tabblad tot tabblad.
Is dit mogelijk via vba of moeten de te kopieren kolommen in de juiste volgorde staan op elk tabblad.?

 

[sylvester-ponte]

Kevein, ik snap het niet helemaal. vul blad 4 eens met de hand in, en plaats het bestand dan nog eens.

 

[AlexCEL]

Met Power Query is het niet zo moeilijk om tabellen aan elkaar te knopen, maar... zorg dat wel voor consequente naamgeving van de relevante kolommen (hoofdletters, VOORnaam i.p.v naam etc.) anders wordt het wel complexer.

 

[HSV]

Bv.

Sub hsv()
Dim sh As Worksheet, sv, x
x = Sheets("blad4").Range("a1:c1")
 For Each sh In Sheets(Array("blad1", "blad2", "blad3"))
  sv = sh.Cells(1).CurrentRegion
    With Application
      sv = .Index(sv, Evaluate("row(2:" & UBound(sv) & ")"), .Match(x, .Index(sv, 1), 0))
      Sheets("blad4").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(sv), 3) = sv
    End With
 Next sh
End Sub

 

[AatB]

Even quick & dirty

Sub Test()

    Dim oms(10)

    Set ws1 = Sheets("Blad1")
    Set ws2 = Sheets("Blad2")
    Set ws3 = Sheets("Blad3")
    Set ws4 = Sheets("Blad4")
    
    ws4.Rows("2:100").ClearContents
    
    o = 0
    While ws4.Cells(1, o + 1) <> ""
        o = o + 1
        oms(o) = ws4.Cells(1, o)
    Wend
    
    rw = 2
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> ws4.Name Then
            Set Rng = ws.Range("A1").CurrentRegion
            Set Rng = Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1, Rng.Columns.Count - 0)
                For n = 1 To o
                    rw1 = rw
                    Set c = ws.Rows(1).Cells.Find(oms(n), LookIn:=xlValues, LookAt:=xlWhole)
                    If Not c Is Nothing Then
                        For Each r In Rng.Columns(c.Column).Cells
                            ws4.Cells(rw1, n) = r
                            rw1 = rw1 + 1
                        Next
                    End If
                Next
                rw = rw1
        End If
    Next

    ws4.Columns.AutoFit

End Sub

 

[KeveinM]

bedankt voor de hulp.
Doen perfect wat ik wou

 

[snb]

Gebruik ingebouwde Excel-faciliteiten:

Sub M_snb()
  For j = 1 To 3
    Sheets("Blad" & j).Cells(1).CurrentRegion.AdvancedFilter 2, , Blad4.Cells(1).CurrentRegion
    Blad4.Cells(1).CurrentRegion.Offset(1).Cut Blad4.Cells(Rows.Count, 10).End(xlUp).Offset(1)
  Next

  Blad4.Cells(2, 10).CurrentRegion.Cut Blad4.Cells(2, 1)
End Sub

 

[AatB]

Gebruik ingebouwde Excel-faciliteiten:

Sub M_snb()
  For j = 1 To 3
    Sheets("Blad" & j).Cells(1).CurrentRegion.AdvancedFilter 2, , Blad4.Cells(1).CurrentRegion
    Blad4.Cells(1).CurrentRegion.Offset(1).Cut Blad4.Cells(Rows.Count, 10).End(xlUp).Offset(1)
  Next

  Blad4.Cells(2, 10).CurrentRegion.Cut Blad4.Cells(2, 1)
End Sub

Krijg hierbij een foutmelding; "Het ophaalbereik heeft geen of ongeldige bestandsnaam"

 

[snb]

Kijk eens in #3

 

[AatB]

Kijk eens in #3

Regel #3 geeft dus de foutmelding. Oplossing?

 

[snb]

Zoek de fouten in het bestand en je bent weer een hoop wijzer in Excel.
En niet citeren geldt ook voor jou al 15 jaar.

 

[AatB]

Dus moeten alle namen exact in alles sheets aanwezig zijn.... Dat was niet het gegeven in het voorbeeld.
Ik vind je oplossing trouwens wel mooi. Ga ik zeker een keer gebruiken

 

[AlexCEL]

Nee, dat was niet zo. Maar hoe kun je anders kolommen aan elkaar linken? Excel kan niet ruiken dat een voornaam eigenlijk een achternaam is, of dat een kolom met naam nu de voor- of achternaam is.

 

[snb]

Wat Powerquery in de achtergrond doet, kan VBA al meer dan 20 jaar.

Sub M_snb()
  c00 = ThisWorkbook.FullName
  c00 = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & c00 & ";Extended Properties=""Excel 12.0"""
   
  c01 = Join([transpose(transpose(Blad4!A1:C1))], ", ")
  c01 = "SELECT " & c01 & " FROM `"
   
  With CreateObject("ADODB.recordset")
    For j = 1 To 3
      .Open c01 & Sheets(j).Name & "$`", c00
      Blad4.Cells(Rows.Count, 1).End(xlUp).Offset(1).CopyFromRecordset .DataSource
      .Close
    Next
  End With
End Sub