Bestanden onder elkaar samenvoegen met één titelrij

[Boboes]

Om data van bestanden uit een bepaalde map samen te voegen in één masterbestand (onder elkaar) gebruik ik de code van Ron de Bruin op

De code werkt goed maar aangezien elk bestand in hetzelfde format is hoeft de titelrij/headers maar één keer gekopieerd te worden. In mijn geval bevindt de titelrij zich in elk bestand steeds op de 6e rij en de data begint vanaf rij 7. Als ik in de code aangeef ‘FirstCell = “A6”, dan wordt voor elk bestand de titelrij ook mee gekopieerd en staan de titelrijen dan tussen de data. Als ik de waarde “A7” opgeef dan wordt er geen enkele titelrij gekopieerd. De bedoeling is dat de titelrij alleen maar in de 1e rij wordt gezet. Hoe krijg ik dat voor elkaar in onderstaande code?

Sub MergeWorkbooksInFolder()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, Fnum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    Dim FirstCell As String
    
    'Fill in the path\folder where the files are
    MyPath = Range("padnaam")

    'Add a slash at the end if the user forget it
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    'If there are no Excel files in the folder exit the sub
    'FilesInPath = Dir(MyPath & "*.xl*")
    FilesInPath = Dir(MyPath & "Testbestand_*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If

    'Fill the array(myFiles)with the list of Excel files in the folder
    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop

    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Add a new workbook with one sheet
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    rnum = 1

    'Loop through all files in the array(myFiles)
    If Fnum > 0 Then
        For Fnum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum), _
                Password:="testpw", WriteResPassword:="testpw", UpdateLinks:=0)
            On Error GoTo 0

            If Not mybook Is Nothing Then

                On Error Resume Next

                With mybook.Worksheets(1)
                    .AutoFilterMode = False
                    FirstCell = "A7" 'header rij begint op A6 en data op A7
                    Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))
                    'Test if the row of the last cell >= then the row of the FirstCell
                    If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then
                        Set sourceRange = Nothing
                    End If
                End With

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    'if SourceRange use all columns then skip this file
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then

                    SourceRcount = sourceRange.Rows.Count

                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "Sorry there are not enough rows in the sheet"
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else

                        'Copy the file name in column A
                        With sourceRange
                            BaseWks.Cells(rnum, "A"). _
                                    Resize(.Rows.Count).Value = MyFiles(Fnum)
                        End With

                        'Set the destrange
                        Set destrange = BaseWks.Range("B" & rnum)

                        'we copy the values from the sourceRange to the destrange
                        sourceRange.Copy
                        With destrange
                            .PasteSpecial xlPasteValues
                            .PasteSpecial xlPasteFormats
                            Application.CutCopyMode = False
                        End With

                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If

        Next Fnum
        BaseWks.Columns.AutoFit
        BaseWks.Cells.VerticalAlignment = xlTop
    End If

ExitTheSub:
    Application.GoTo BaseWks.Cells(1)
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

 

[VenA]

Volgens mij is er wel wat simpeler code voor te verzinnen/vinden. Zie bv hier: https://www.helpmij.nl/forum/showthread.php/949193-100-excel-bestanden-samenvoegen-in-1-werkmap

Waarschijnlijk even

sourceRange.Copy

aanpassen in

SourceRange.Offset(IIf(rnum = 1, 0, 1)).Copy

 

[Boboes]

Beste VenA, bedankt voor je reactie. Ik kan er helaas niet zo veel mee omdat ik niet zo'n VBA-nerd ben dat ik die oplossing kan volgen met al die verwijzingen. Bovendien houdt de code van Ron de Bruin rekening met (tijdelijk) opheffen beveiligde importbestanden, worden alleen bestanden ingelezen die beginnen met bepaalde naam, startregel, etc. De code is weliswaar langer maar kan ik redelijk volgen..... Dus ik weet niet of het mogelijk is om de code van RdB aan te passen.

 

[NoellaG]

Je kan misschien een extra variabele gebruiken:
in de declaratiesectie zet je
dim bCopyTitleRow as Boolean

Vooraan in je code, voor je de loop begint zet je die op True
bCopyTitleRow = true

en je kan dan het volgend stuk code aanpassen:

 With mybook.Worksheets(1)
                    .AutoFilterMode = False
                 [B]  if bCopyTitleRow   then
                       FirstCell = "A6" 'header rij begint op A6 en data op A7
                       bCopyTiteRow  = False
                   else
                       FirstCell = "A7" 'header rij begint op A6 en data op A7
                   end if[/B]                   
               Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))
                    'Test if the row of the last cell >= then the row of the FirstCell
                    If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then
                        Set sourceRange = Nothing
                    End If
                End With

 

[VenA]

De aanpassing in #2 is ook bedoeld voor de code van RdB.

 

[Boboes]

NoellaG en VenA: allebei bedankt voor de hulp! Ik heb de twee (verschillende) oplossingen geprobeerd en ze werkten!
@ VenA: sorry, ik was vanuit jouw eerste antwoord direct naar de link gegaan en was toen effe de weg kwijt....

Nogmaals dank.

 

[snb]

Hou het simpel:
Als je de gegevens (niet de opmaak) van alle xlsx-bestanden in Folder G:\OF\ onder elkaar wil zetten:

Sub M_snb()
  sn = Split(CreateObject("wscript.shell").exec("cmd /c dir ""G:\OF\*.xlsx"" /s/b").stdout.readall, vbCrLf)   '   1

  For j = 0 To UBound(sn)-1
     With GetObject(sn(j))                                     '    2
        sp = .Sheets(1).UsedRange.Offset(Abs(j > 0))           '    3  + 4
        .Close 0                                               '    5
     End With

     Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(Abs(j > 0)).Resize(UBound(sp), UBound(sp, 2)) = sp    '   6
  Next
End Sub

1. zet alle xlsx bestanden in folder G:\OF in array variabele sn
2. open ieder bestand in Array variabele sn onzichtbaar
3. zet de inhoud van werkblad 1 van het onzichtbaar geopende bestand in array variabele sp;
4. verschuif vanaf het tweede bestand de inhoud 1 rij naar beneden om de kopregel te vermijden
5. sluit het onzichtbare bestand
6. zet de inhoud van variabele sp onder de bestaande inhoud van werkblad 1 van het actieve werkboek.