Need VBA code: Merge all Excel files in a floder to a new excel Sheet

[Veenu90]

HI,

I am a beginner in Excel and need help in writing a VBA code. We work in Excel 2010 and every week I need to prepare a consolidated excel file after merging all the Shared excel files in a folder. I do it manually by copy paste and it takes lots of time and effort. Could someone help me to do it via VBA code. Things that I need are:

1: All data is in Sheet1 of every Excel workbook
2: Row 1 contains the column names in every excel file so I need that the hadings are being copied to consolidated sheet only once and from other files in folder the data is being copied from Row 2. (If Possible)
2: As we work on a shared excel file so sometimes it has filters applied on columns as well, so i need to remove filters as well before I copy the rows.

Thanks for your time.

 

[ParamRay]

Before running the macro, you'll first need to change this line to match the folder containing your workbooks:

FileFold = "C:\Users\jsmith\Desktop"

The code is as follows. You don't need to have any of your workbooks open in order to run this.

Sub Test()

    Dim FileFold As String
    Dim FileSpec As String
    Dim FileName As String
    Dim ShtCnt As Long
    Dim RowCnt As Long
    Dim Merged As Workbook
    Dim wb As Workbook
    Dim ws As Worksheet
    
    FileFold = "C:\Users\jsmith\Desktop" 'set the folder
    
    FileSpec = FileFold & Application.PathSeparator & "*.xl*"
    FileName = Dir(FileSpec)
    
    'Exit if no files found
    If FileName = vbNullString Then
        MsgBox Prompt:="No files were found that match " & FileSpec, Buttons:=vbCritical, Title:="Error"
        Exit Sub
    End If
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
    ShtCnt = 0
    RowCnt = 1
    
    Set Merged = Workbooks.Add
    
    Do While FileName <> vbNullString
        ShtCnt = ShtCnt + 1
        Set wb = Workbooks.Open(FileName:=FileFold & Application.PathSeparator & FileName, UpdateLinks:=False)
        Set ws = wb.Worksheets("Sheet1")
        With ws
            If .FilterMode Then .ShowAllData
            If ShtCnt > 1 Then .Rows(1).EntireRow.Delete Shift:=xlUp
            .Range("A1").CurrentRegion.Copy Destination:=Merged.Worksheets(1).Cells(RowCnt, 1)
        End With
        wb.Close SaveChanges:=False
        RowCnt = Application.WorksheetFunction.CountA(Merged.Worksheets(1).Columns("A:A")) + 1
        FileName = Dir
    Loop
    
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
    MsgBox Prompt:="Finished merging.", Buttons:=vbInformation, Title:="Success"

End Sub

 

[Veenu90]

Thank you so much for your help. It really helped me and did exactly that I needed.

 

[ParamRay]

Thank you so much for your help. It really helped me and did exactly that I needed.

No problem.

Glad to help you.

 

[wmiola]

Dear gpeacock,
I have used your macro and it is very helpful. However, I am finding an issue that I do not know how to solve and wondered if you can assist. I am a novice at VBA.
I am running the macro on a folder with files of different extensions, so I changed the code. Instead of "*.xl*" I am using "*.x*"
It is compiling all files correctly.
I would like to confirm if if the macro is meant to show all content. Will it unfilter, unhide and unfreeze contents in the files before merging them?
The problem I am finding is: although it is combining all files, SOME of the content from the originals, in the last 3 or 4 columns, is not being included when the files are combined.
I am puzzled because most of the time all the content is compiled correctly and only in a few cases it is not. I have not been able to identify any reason why.
Would you kindly be able to assist?
Many thanks in advance.

 

[navafolk]

Hi gpeacock, How can I combine first row?

Before running the macro, you'll first need to change this line to match the folder containing your workbooks:

FileFold = "C:\Users\jsmith\Desktop"

The code is as follows. You don't need to have any of your workbooks open in order to run this.

Sub Test()

    Dim FileFold As String
    Dim FileSpec As String
    Dim FileName As String
    Dim ShtCnt As Long
    Dim RowCnt As Long
    Dim Merged As Workbook
    Dim wb As Workbook
    Dim ws As Worksheet
    
    FileFold = "C:\Users\jsmith\Desktop" 'set the folder
    
    FileSpec = FileFold & Application.PathSeparator & "*.xl*"
    FileName = Dir(FileSpec)
    
    'Exit if no files found
    If FileName = vbNullString Then
        MsgBox Prompt:="No files were found that match " & FileSpec, Buttons:=vbCritical, Title:="Error"
        Exit Sub
    End If
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
    ShtCnt = 0
    RowCnt = 1
    
    Set Merged = Workbooks.Add
    
    Do While FileName <> vbNullString
        ShtCnt = ShtCnt + 1
        Set wb = Workbooks.Open(FileName:=FileFold & Application.PathSeparator & FileName, UpdateLinks:=False)
        Set ws = wb.Worksheets("Sheet1")
        With ws
            If .FilterMode Then .ShowAllData
            If ShtCnt > 1 Then .Rows(1).EntireRow.Delete Shift:=xlUp
            .Range("A1").CurrentRegion.Copy Destination:=Merged.Worksheets(1).Cells(RowCnt, 1)
        End With
        wb.Close SaveChanges:=False
        RowCnt = Application.WorksheetFunction.CountA(Merged.Worksheets(1).Columns("A:A")) + 1
        FileName = Dir
    Loop
    
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
    MsgBox Prompt:="Finished merging.", Buttons:=vbInformation, Title:="Success"

End Sub

 

[12hcks]

What if the sheet one is named uniquely according to the file name?