Bestanden samenvoegen

[vrouw]

Het lukt mij maar niet meerdere bestanden die in één map staan samen te voegen in één nieuw bestand.
De bedoeling is dat(eventueel) de kop blijft bestaan en de regels uit andere bestanden onder elkaar komen in één werkblad.
zie de 2 bijlage die dan in één nieuw bestand moeten koemen

Nu ben ik een leek met VBA maar met knippen en plakken kom ik vaak een heel eind.
Ik heb onderstaande code gevonden op internet maar als ik die draai dan krijg ik wel een nieuw bestand maar er staat dan maar één regel in.

Sub VoegExcelBestandenSamen()
' [TOPIC=848630///][NOHTML][rml][ Excel] Meerdere bestanden samenvoegen[/rml][/NOHTML][/TOPIC]

Dim wbSingleWorkbook, wbFinalWorkbook           As Excel.Workbook
Dim wsSheet                                     As Excel.Worksheet
Dim strPath, strWorkbook(100)                   As String
Dim intCounter, n                               As Integer
    
    strPath = "C:\Temp\"        ' Map met .xls-bestanden
    
    intCounter = 1              ' teller
    
    strWorkbook(intCounter) = Dir(strPath & "*.xls")
    
    Do While strWorkbook(intCounter) <> ""
    
        intCounter = intCounter + 1
        strWorkbook(intCounter) = Dir
        
    Loop
    
    intCounter = intCounter - 1 ' want de laatste is leeg
    
    Set wbFinalWorkbook = Workbooks.Add
    
        
    For n = 1 To intCounter
    
        Set wbSingleWorkbook = Workbooks.Open(Filename:=strPath _
            & strWorkbook(n), ReadOnly:=True)
            
        For Each wsSheet In wbSingleWorkbook.Sheets
        
            wsSheet.Copy After:=wbFinalWorkbook.Sheets(wbFinalWorkbook.Sheets.Count)
            wbFinalWorkbook.Sheets(wbFinalWorkbook.Sheets.Count).Name = strWorkbook(n) _
             & "|" & wsSheet.Name
            
        Next wsSheet
        wbSingleWorkbook.Close
    
    Next n
    
    Application.DisplayAlerts = False
    wbFinalWorkbook.Sheets(1).Delete
    wbFinalWorkbook.Sheets(2).Delete
    wbFinalWorkbook.Sheets(3).Delete
    Application.DisplayAlerts = True
    
    Set wbSingleWorkbook = Nothing

End Sub

Weet iemand wat er fout gaat?

Bekijk bijlage OC1.xlsBekijk bijlage OC2.xls

 

[VenA]

De vraag, code en bestanden sluiten niet echt op elkaar aan. Mogelijk bedoel je zoiets

Sub VenA()
  c00 = "E:\Temp\"
  With Workbooks.Add
    c01 = Dir(c00 & "*.xls")
    Do While Len(c01) > 0
        With Workbooks.Open(c00 & c01)
          ar = .Sheets(1).Range("A3:I" & Application.Max(3, .Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row))
          .Close 0
        End With
      .Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar), 9) = ar
      c01 = Dir
    Loop
  End With
End Sub