Merge Excel Files in Folder into Bottom of Current Worksheet

[sheexin]

Hi, I'm currently using Ron De Bruin's code to merge multiple excel files in a folder. I've managed to modify the code to paste the data into the current workbook, instead of a new one.

I want to paste the data at the first unfilled row of the current worksheet as the pasted data should add on to previous pasted data. The worksheet would be updated regularly with new combined files from new folders. I know that to find the first unfilled cell would be Range (“A1”).End(xlDown).Offset(1,0) but I only managed to edit the positions of Please Wait and Ready, but not the pasted data. If I'm not wrong, the pasted data would start from A3 onwards. Any suggestions?

Option Explicit


'Important: this Dim line must be at the top of your module
Public MyFiles As String


Function GetFilesOnMacWithOrWithoutSubfolders(Level As Long, ExtChoice As Long, _
                                              FileFilterOption As Long, FileNameFilterStr As String)
'Ron de Bruin,Version 3.0 : 1 May 2015
'Thanks to DJ Bazzie Wazzie(poster on MacScripter) for his great help.
    Dim ScriptToRun As String
    Dim folderPath As String
    Dim FileNameFilter As String
    Dim Extensions As String


    On Error Resume Next
    folderPath = MacScript("choose folder as string")
    If folderPath = "" Then Exit Function
    On Error GoTo 0


    Select Case ExtChoice
    Case 0: Extensions = "(xls|xlsx|xlsm|xlsb)"  'xls, xlsx , xlsm, xlsb
    Case 1: Extensions = "xls"    'Only  xls
    Case 2: Extensions = "xlsx"    'Only xlsx
    Case 3: Extensions = "xlsm"    'Only xlsm
    Case 4: Extensions = "xlsb"    'Only xlsb
    Case 5: Extensions = "csv"    'Only csv
    Case 6: Extensions = "txt"    'Only txt
    Case 7: Extensions = ".*"    'All files with extension, use *.* for everything
    Case 8: Extensions = "(xlsx|xlsm|xlsb)"  'xlsx, xlsm , xlsb
    Case 9: Extensions = "(csv|txt)"   'csv and txt files
        'You can add more filter options if you want,
    End Select


    Select Case FileFilterOption
    Case 0: FileNameFilter = "'.*/[^~][^/]*\\." & Extensions & "$' "  'No Filter
    Case 1: FileNameFilter = "'.*/" & FileNameFilterStr & "[^~][^/]*\\." & Extensions & "$' "    'Begins with
    Case 2: FileNameFilter = "'.*/[^~][^/]*" & FileNameFilterStr & "\\." & Extensions & "$' "    ' Ends With
    Case 3: FileNameFilter = "'.*/([^~][^/]*" & FileNameFilterStr & "[^/]*|" & FileNameFilterStr & "[^/]*)\\." & Extensions & "$' "   'Contains
    End Select


    folderPath = MacScript("tell text 1 thru -2 of " & Chr(34) & folderPath & _
                           Chr(34) & " to return quoted form of it's POSIX Path")
    folderPath = Replace(folderPath, "'\''", "'\\''")


    If Val(Application.Version) < 15 Then
        ScriptToRun = ScriptToRun & "set OSAConverter to ""osascript -e 'on run argv" & Chr(13)
        ScriptToRun = ScriptToRun & "return posix file (item 1 of argv) as string" & Chr(13)
        ScriptToRun = ScriptToRun & "end run' {} \\;""" & Chr(13)
        ScriptToRun = ScriptToRun & "do shell script """ & "find -E " & _
                      folderPath & " -iregex " & FileNameFilter & " -maxdepth " & _
                      Level & " -exec ""  & OSAConverter"
    Else
        ScriptToRun = ScriptToRun & "do shell script """ & "find -E " & _
                      folderPath & " -iregex " & FileNameFilter & "-maxdepth " & _
                      Level & """ "
    End If
    On Error Resume Next
    MyFiles = MacScript(ScriptToRun)
    On Error GoTo 0
End Function




Function RDB_Last(choice As Integer, rng As Range)
'Ron de Bruin, 5 May 2008
'Case 1 = last row
'Case 2 = last column
'Case 3 = last cell
    Dim lrw As Long
    Dim lcol As Integer


    Select Case choice


    Case 1:
        On Error Resume Next
        RDB_Last = rng.Find(What:="*", _
                            after:=rng.Cells(1), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
        On Error GoTo 0


    Case 2:
        On Error Resume Next
        RDB_Last = rng.Find(What:="*", _
                            after:=rng.Cells(1), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
        On Error GoTo 0


    Case 3:
        On Error Resume Next
        lrw = rng.Find(What:="*", _
                       after:=rng.Cells(1), _
                       Lookat:=xlPart, _
                       LookIn:=xlFormulas, _
                       SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious, _
                       MatchCase:=False).Row
        On Error GoTo 0


        On Error Resume Next
        lcol = rng.Find(What:="*", _
                        after:=rng.Cells(1), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
        On Error GoTo 0


        On Error Resume Next
        RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
        If Err.Number > 0 Then
            RDB_Last = rng.Cells(1).Address(False, False)
            Err.Clear
        End If
        On Error GoTo 0
    End Select
End Function

Sub MergeCode2()
    Dim BaseWks As Worksheet
    Dim rnum As Long
    Dim CalcMode As Long
    Dim MySplit As Variant
    Dim FileInMyFiles As Long
    Dim Mybook As Workbook
    Dim sourceRange As Range
    Dim destrange As Range
    Dim SourceRcount As Long
    Dim FirstCell As String


    'Add a new workbook with one sheet
    Set BaseWks = ThisWorkbook.Sheets("sheet1")
    BaseWks.Range("A1").Font.Size = 36
    BaseWks.Range("A1").Value = "Please Wait"
    rnum = 3


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


    'Clear MyFiles to be sure that it not return old info if no files are found
    MyFiles = ""


    'Get the files, set the level of folders and extension in the code line below
    Call GetFilesOnMacWithOrWithoutSubfolders(Level:=1, ExtChoice:=0, FileFilterOption:=0, FileNameFilterStr:="")
    'Level                       :  1= Only the files in the folder you select, 2 to ? levels of subfolders
    'ExtChoice               :  0=(xls|xlsx|xlsm|xlsb), 1=xls , 2=xlsx, 3=xlsm, 4=xlsb, 5=csv, 6=txt, 7=all files, 8=(xlsx|xlsm|xlsb), 9=(csv|txt)
    'FileFilterOption     :  0=No Filter, 1=Begins, 2=Ends, 3=Contains
    'FileNameFilterStr  : Search string used when FileFilterOption = 1, 2 or 3


    ' Work with the files if MyFiles is not empty.
    If MyFiles <> "" Then


        MySplit = Split(MyFiles, Chr(13))
        For FileInMyFiles = LBound(MySplit) To UBound(MySplit)


            Set Mybook = Nothing
            On Error Resume Next
            Set Mybook = Workbooks.Open(MySplit(FileInMyFiles))
            On Error GoTo 0


            If Not Mybook Is Nothing Then


                On Error Resume Next


                With Mybook.Worksheets(1)
                    FirstCell = "A2"
                    Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))
                    'Test if the row of the last cell is equal to or greater than the row of the first cell.
                    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 = MySplit(FileInMyFiles)
                        End With


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


                        'we copy the values from the sourceRange to the destrange
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value


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


        Next FileInMyFiles
        BaseWks.Columns.AutoFit
    End If


ExitTheSub:
    BaseWks.Range("A1").Value = "Ready"
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

Thanks!

[snb]

I'd use

sub M_snb()
   sn=filter(split(createobject("wscript.shell").exec("cmd /c dir ""G:\OF\*.xls*"" /b/s"),vbcrlf),":")

   for j=0 to ubound(sn()
     with getobject(sn(j))
       sp=.sheets(1).usedrange
       .close 0
     end with

     thisworkbook.sheet1.cells(rows.count,1).end(xlup).offset(1).resize(ubound(sp),ubound(sp,2))=sp
  next
End sub

[sheexin]

Thanks for the reply. There were some errors so I've adjusted the code as such:

Sub M_snb()
    sn = Filter(Split(CreateObject("wscript.shell").exec("cmd /c dir ""G:\OF\*.xls*"" /b/s"), vbCrLf), ":")
     
    For j = 0 To UBound(sn())
        With GetObject(sn(j))
            sp = .Sheets(1).UsedRange
            .Close 0
        End With
         
        ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(sp), UBound(sp, 2)) = sp
    Next
End Sub

However, when I run the sub, it says run time error 429, activex component can't create object. sn = Filter(Split(CreateObject("wscript.shell").exec("cmd /c dir ""G:\OF\*.xls*"" /b/s"), vbCrLf), ":") is highlighted.

Moreover, am I supposed to run this sub after running the mergecode2?

In case it matters, I'm using excel 2011 on mac. Thanks!

[snb]

In case it matters, I'm using excel 2011 on mac.

It's essential.
My code assumes running in Windows (that's wscript.shell).

[Tom Jones]

As SNB says the code is designed to run under Windows, but would have to change the path to the folder with the files - in code is G:\OF\ and I doubt that is the same way and where are your files.

[sheexin]

Hi all, I have found a simpler roundabout solution. Basically, I created a second sheet where the database should be. Sheet 1 would be where Ron de Bruin's code is run, and then I would use VBA to copy and paste the relevant rows and columns into the next empty cell in Sheet 2. My code is as such:

Sub copy()

    'copy
    Worksheets("Sheet1").Activate
    If IsEmpty(Range("A1").Value) = False Then
    Range("B3").Select
    Range(ActiveCell, ActiveCell.End(xlToRight).End(xlDown)).Select
    Selection.copy
    
    'paste
    'empty
    Worksheets("All").Activate
    If IsEmpty(Range("A1").Value) = True Then
    Range("A1").PasteSpecial
    Range("A1").PasteSpecial xlPasteColumnWidths
    
    End If
    'not empty
    If IsEmpty(Range("A1").Value) = False Then
    Range("A1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteColumnWidths
    Range("A1").End(xlDown).Offset(1, 0).PasteSpecial
    


    End If


    Worksheets("Sheet1").Cells.Clear
    
    End If
    
    If IsEmpty(Range("A1").Value) = True Then
    MsgBox ("No Data")
    End If


End Sub

Thanks all for your kind help!