Merge all files in folder macro

schielrn

schielrn

Well-known Member
Joined
Apr 4, 2007
Messages
6,941
Ok I found this macro on the board and modified it some for my situation, but here is where I am at. The macro opens all workbooks in a given folder and I have modified it to go to a specific workbook that I am running the macro out of. The problem is that I want to have the so called master file in the same folder as the merging files. Where should I add this line:

If wbSource <> wbDest Then
'Perform code
End If

I'm not positive if wbSource is the actual workbooks being opened or a replica of them, but I believe that is the line I would need. I know I could fool around with it and probably figure it out, but I figure someone may be able to look at it and know right away. In the mean time I will try to figure it out. Here is the program:

Code: 
Option Explicit
Public strPath As String

Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
                                     Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
                                   Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer

    '   Root folder = Desktop
    bInfo.pidlRoot = 0&

    '   Title in the dialog
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = Msg
    End If

    '   Type of directory to return
    bInfo.ulFlags = &H1

    '   Display the dialog
    x = SHBrowseForFolder(bInfo)

    '   Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function


Sub MergeFiles()
    Dim strFolder As String, lngFilecounter As Long
    Dim wbDest As Workbook, shtDest As Worksheet
    Dim wbSource As Workbook

    strFolder = GetDirectory("Select a folder containing Excel files you want to merge")
    Application.ScreenUpdating = False
    If Len(strFolder) = 0 Then Exit Sub

    'Create a new workbook.  This will be for the merged data
    Set wbDest = ActiveWorkbook
    Set shtDest = wbDest.Sheets(1)

    With Application.FileSearch
        .NewSearch
        .LookIn = strFolder
        .FileType = msoFileTypeExcelWorkbooks
        .Execute
        If .FoundFiles.Count = 0 Then Exit Sub

        For lngFilecounter = 1 To .FoundFiles.Count

            Set wbSource = Workbooks.Open(.FoundFiles(lngFilecounter))
            ActiveSheet.Range(Cells(2, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count)).Copy
            shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).PasteSpecial xlPasteAll
            Application.DisplayAlerts = False
            wbSource.Close False
            Application.DisplayAlerts = True
        Next lngFilecounter

    End With
    Range("A1").Select
    Application.ScreenUpdating = True
    MsgBox "Done!"
End Sub
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
Sort by date Sort by votes
Ok I have pinpoint the place where I believe it needs to go, but I can't get the syntax, I keep getting an invalid qualifier error. I have tried the following with these comments:

Code: 
            If Application.FileSearch.FoundFiles(lngFilecounter).Name <> wbDest.Name Then
            Set wbSource = Workbooks.Open(.FoundFiles(lngFilecounter))
And
Code: 
            If .FoundFiles(lngFilecounter).Name <> wbDest.Name Then
            Set wbSource = Workbooks.Open(.FoundFiles(lngFilecounter))
Invalid qualifier on FoundFiles


Code: 
Set wbSource = Workbooks.Open(.FoundFiles(lngFilecounter))
If wbSource.Name <> wbDest.Name Then

Can't do it here because it opens the workbook before this point. Anyone know syntaxically (if thats a word) how to do what I tried first?

I could make the last solution work by sendkeys to select no do not open this book again, but I'd rather not do that.

Code: 
Application.SendKeys "{RIGHT}"
Application.SendKeys "{ENTER}"
 
Upvote 0
How's this?

Code: 
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
    
    ThisWB = ThisWorkbook.Name
    
    path = GetDirectory("Select a folder containing Excel files you want to merge")
    If Len(Filename) = 0 Then Exit Sub

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set shtDest = ActiveWorkbook.Sheets(1)
    Filename = Dir(path & "\*.xls", vbNormal)

    Do Until Filename = vbNullString
        If Not Filename = ThisWB Then
            Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
            Set CopyRng = Wkb.Sheets(1).Range(Cells(2, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
            Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
            CopyRng.Copy Dest
            Wkb.Close False
        End If
        
        Filename = Dir()
    Loop

    Range("A1").Select
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    MsgBox "Done!"
End Sub
 
Upvote 0
Thanks Yogi that was extremely fast compared to the other one. It moved 60,000 from 4 workbooks in just a few seconds. The other one took nearly around 30 seconds to move the same data. I had to modify yours because you had an if sattement in the wrong place.

You were checking this before you filled file name with a string value so I had to move it down in the code:

Code: 
If Len(Filename) = 0 Then Exit Sub


Here is the correct code in case anyone needs this:

Code: 
Option Explicit
Public strPath As String

Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
                                     Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
                                   Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer

    '   Root folder = Desktop
    bInfo.pidlRoot = 0&

    '   Title in the dialog
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = Msg
    End If

    '   Type of directory to return
    bInfo.ulFlags = &H1

    '   Display the dialog
    x = SHBrowseForFolder(bInfo)

    '   Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function

    Sub MergeFiles2()
    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
    
    ThisWB = ThisWorkbook.Name
    
    path = GetDirectory("Select a folder containing Excel files you want to merge")

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set shtDest = ActiveWorkbook.Sheets(1)
    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(2, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
            Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
            CopyRng.Copy Dest
            Wkb.Close False
        End If
        
        Filename = Dir()
    Loop

    Range("A1").Select
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    MsgBox "Done!"
End Sub
 
Upvote 0
Ok one last question on this. How do I make this an add-in or available for all workbooks I open? Do I save it as an xla and move it to the add-in folder? Is there an easier way?
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Solved
Getting code to work in 64 Bit Excel
Replies
5
Views
200
Gborden800
G
S
  • Question
List All SharePoint Files In Folder
Replies
2
Views
101
sspatriots
S
KlausW
  • Question
browse to folders and subfolders an copy cell
Replies
0
Views
218
KlausW
KlausW
R
  • Question
Problems with getting fileinfo
Replies
1
Views
618
Zot
Z
C
  • Solved
Macro works for one file, does not work for all files in the directory
2
Replies
13
Views
633
Alex Blakenburg
A

Forum statistics

Threads
1,215,756
Messages
6,126,691
Members
449,329
Latest member
tommyarra

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top