Consolidating 2 files into 1 single file with 1 worksheet

[singhal_amit]

Hello Friends,

Need your help in writing a macro since i am very new to the world of Macros.

Problem Statement: There are 2 separate .xlsb files at 2 different locations. Currently i manually copy the data from each file into a new workbook in a single sheet. So i want to write a macro which will the following:

1) Ask me the location of the files.
2) Copy the data of the 2 files in a single worksheet of a new workbook.

Currently what i have is a macro which is copying the sheets of the 2 files as it is in the new workbook. Below is the code:

Sub MergeExcelFiles()
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook

fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm;*.xlsb),*.xls;*.xlsx;*.xlsm;*.xlsb", Title:="Choose Excel files to merge", MultiSelect:=True)

If (vbBoolean <> VarType(fnameList)) Then

If (UBound(fnameList) > 0) Then
countFiles = 0
countSheets = 0

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set wbkCurBook = ActiveWorkbook

For Each fnameCurFile In fnameList
countFiles = countFiles + 1

Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)

For Each wksCurSheet In wbkSrcBook.Sheets
countSheets = countSheets + 1
wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
Next

wbkSrcBook.Close SaveChanges:=False

Next

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
End If

Else
MsgBox "No files selected", Title:="Merge Excel files"
End If
End Sub

Please help me on this so that i can further look into improving my process of reporting. Thanks alot in advance.

Amit Singhal

 

[DanteAmor]

Try this to merge 2 files.

Sub Merge_Files()


    Dim file1 As String, file2 As String
    Dim w2 As Workbook, w3 As Workbook, w4 As Workbook
    Dim sh As Worksheet
    Dim u As Long, u4 As Long, n As Long
    '
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    '
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Seleccione archivo de excel"
        .Filters.Add "Archivos excel", "*.xls*"
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path & "\"
        If Not .Show Then
            MsgBox "No files selected", Title:="Merge Excel files"
            Exit Sub
        Else
            file1 = .SelectedItems.Item(1)
        End If
    End With
    '
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Seleccione archivo de excel"
        .Filters.Add "Archivos excel", "*.xls*"
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path & "\"
        If Not .Show Then
            MsgBox "No files selected", Title:="Merge Excel files"
            Exit Sub
        Else
            file2 = .SelectedItems.Item(1)
        End If
    End With
    '
    'Open files
    Set w2 = Workbooks.Open(file1)
    Set w3 = Workbooks.Open(file2)
    Set w4 = Workbooks.Add
    'Copy sheets
    For Each sh In w2.Sheets
        n = n + 1
        u = sh.UsedRange.Rows(sh.UsedRange.Rows.Count).Row
        sh.Rows("1:" & u).Copy
        u4 = w4.Sheets(1).UsedRange.Rows(w4.Sheets(1).UsedRange.Rows.Count).Row + 1
        w4.Sheets(1).Range("A" & u4).PasteSpecial xlAll
        w4.Sheets(1).Range("A" & u4).PasteSpecial xlValues
    Next
    For Each sh In w3.Sheets
        n = n + 1
        u = sh.UsedRange.Rows(sh.UsedRange.Rows.Count).Row
        sh.Rows("1:" & u).Copy
        u4 = w4.Sheets(1).UsedRange.Rows(w4.Sheets(1).UsedRange.Rows.Count).Row + 1
        w4.Sheets(1).Range("A" & u4).PasteSpecial xlAll
        w4.Sheets(1).Range("A" & u4).PasteSpecial xlValues
    Next
    w2.Close False
    w3.Close False
    w4.SaveAs "Newflie.xlsx"
    Application.ScreenUpdating = False
    '
    MsgBox "Processed. " & vbCrLf & "Merged " & n & " worksheets", Title:="Merge Excel files"
End Sub

Let me know if you have a doubt.

 

[singhal_amit]

Thanks for your help.. It worked like a charm.. Only one thing suppose i create a new file & add this code in it then it will again create a new file but if i want the merging to be done in a new worksheet in my new file only then what changes should i do, please let me know.

I hope you understood my query.

Thanks in advance!

Amit Singhal

 

[DanteAmor]

Try:

Sub Merge_Files()


    Dim file1 As String, file2 As String
    Dim w2 As Workbook, w3 As Workbook, w4 As Workbook
    Dim sh As Worksheet
    Dim u As Long, u4 As Long, n As Long
    '
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    '
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Seleccione archivo de excel"
        .Filters.Add "Archivos excel", "*.xls*"
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path & "\"
        If Not .Show Then
            MsgBox "No files selected", Title:="Merge Excel files"
            Exit Sub
        Else
            file1 = .SelectedItems.Item(1)
        End If
    End With
    '
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Seleccione archivo de excel"
        .Filters.Add "Archivos excel", "*.xls*"
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path & "\"
        If Not .Show Then
            MsgBox "No files selected", Title:="Merge Excel files"
            Exit Sub
        Else
            file2 = .SelectedItems.Item(1)
        End If
    End With
    '
    'Open files
    Set w2 = Workbooks.Open(file1)
    Set w3 = Workbooks.Open(file2)
    Set w4 = ThisWorkbook
    Set sh4 = w4.Sheets.Add(after:=w4.Sheets(w4.Sheets.Count))
    'Copy sheets
    For Each sh In w2.Sheets
        n = n + 1
        u = sh.UsedRange.Rows(sh.UsedRange.Rows.Count).Row
        sh.Rows("1:" & u).Copy
        u4 = sh4.UsedRange.Rows(sh4.UsedRange.Rows.Count).Row + 1
        sh4.Range("A" & u4).PasteSpecial xlAll
        sh4.Range("A" & u4).PasteSpecial xlValues
    Next
    For Each sh In w3.Sheets
        n = n + 1
        u = sh.UsedRange.Rows(sh.UsedRange.Rows.Count).Row
        sh.Rows("1:" & u).Copy
        u4 = sh4.UsedRange.Rows(sh4.UsedRange.Rows.Count).Row + 1
        sh4.Range("A" & u4).PasteSpecial xlAll
        sh4.Range("A" & u4).PasteSpecial xlValues
    Next
    w2.Close False
    w3.Close False
    w4.Save
    Application.ScreenUpdating = False
    '
    MsgBox "Processed. " & vbCrLf & "Merged " & n & " worksheets", Title:="Merge Excel files"
End Sub