VBA Sub MergeFiles aanpassen voor tweede, derde en vierde tabblad

[arrie23]

Beste lezer,

Ik heb 40 losse Excelbestanden met elk 4 tabbladen. Hiervan wil ik 1 groot Excelbestand maken met vier tabbladen. Handmatig 40 keer kopieren en plakken in een nieuw tabblad (en dat voor elk van de 4 tabbladen) is nogal tijdrovend. Ik heb op Internet een VBA-script gevonden dat het perfect doet voor tabblad 1 van elk van de bestanden. Deze worden keurig samengevoegd in 1 nieuw tabblad. Echter nu wil ik hetzelfde doen voor tabbladen 2, 3 en 4. Helaas schiet mijn kennis van VBA tekort om het script zodanig aanpassen dat hij van elk bestand niet de eerste maar de tweede (of derde of vierde) tabbladen samenvoegt. Het is waarschijnlijk een kleine aanpassing aan het script maar ik weet niet waar. Heeft iemand een suggestie?
Hieronder het gevonden VBA-script (ik sta overigens open voor alternatieve oplossingen mocht iemand een beter idee hebben):

Sub MergeFiles()
Dim path As String, ThisWB As String, lngFilecounter As Long
Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
Dim Filename As String, Wkb As Workbook
Dim CopyRng As Range, Dest As Range
Dim RowofCopySheet As Integer
RowofCopySheet = 1 ' Row to start on in the sheets you are copying from
ThisWB = ActiveWorkbook.Name

path = ("H:\Belangrijk\Test\Samenvoegen\Bestanden")
Application.EnableEvents = False
Application.ScreenUpdating = False
Set shtDest = ActiveWorkbook.Sheets("Blad1")
Filename = Dir(path & "\*.xls", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
If Not Filename = ThisWB Then
Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, Cells(1, Columns.Count).End(xlToLeft).Column))
Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
CopyRng.Copy
Sheets("Data").Select
Dest.PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False 'Clear Clipboard
Wkb.Close False
End If

Filename = Dir()
Loop

Range("A1").Select

Application.EnableEvents = True
Application.ScreenUpdating = True

MsgBox "Done!"
End Sub

 

[Warme bakkertje]

Sub MergeFiles()
Dim fName As String, CopyRng As Range
Const Mypath = "H:\Belangrijk\Test\Samenvoegen\Bestanden"
With Application
    .ScreenUpdating = False
    .EnableEvents = False
On Error Resume Next
fName = Dir(Mypath & "\*.xls", vbNormal)
Do Until fName = vbNullString
    If Not fName = ThisWorkbook.Name Then
        Workbooks.Open Mypath & "\" & fName
        For i = 1 To 4
            With Workbooks(fName).Sheets(i)
                Set CopyRng = .Range(.Cells(1, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column))
            End With
            CopyRng.Copy
            With ThisWorkbook.Sheets(i)
                .Range("A" & .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).PasteSpecial xlPasteValuesAndNumberFormats
            End With
            Application.CutCopyMode = False 'Clear Clipboard
        Next
        ActiveWorkbook.Close False
    End If
    fName = Dir()
Loop
    .Goto ThisWorkbook.Sheets(1).Range("A1"), True
    .EnableEvents = True
    .ScreenUpdating = True
End With
MsgBox "Done!"
End Sub

 

[arrie23]

Beste Rudi,

Ik heb het zojuist getest en het werkt perfect!! (maar dat wist je waarschijnlijk al :d). Dit scheelt mij echt een enorme hoeveelheid handwerk!
Heel erg bedankt!