Combine Excel workbooks into one master file copy using ranges

Question

Hello I need to combine a list of workbooks by selecting a workbook from a directory. Copying a range of data from the active workbook and pasting it into the new master workbook. Then copying another range of data from another workbook to paste adjacent to the newly pasted cell. Then I need to repeat the process for multiple files in a directory. Here is the code I have found thus far:

Option Explicit

'Combine Workbooks
'This sample goes through all the Excel files in a specified directory and combines theminto
'a single workbook.  It renames the sheets based on the name of the original workbook:
Sub CombineSourceWorkbooks()
Dim CurFile As String, DirLoc As String
Dim DestWb As Workbook
Dim wbkOpen As Workbook
Dim WS As Object 'allows for different sheet types

DirLoc = "C:\MyFiles\"
CurFile = Dir(DirLoc & "*.xls")

Application.ScreenUpdating = False
Application.EnableEvents = False

Set DestWb = Workbooks.Add(xlWorksheet)

Do While CurFile <> vbNullString
    Dim OrigWb As Workbook
    Set OrigWb = Workbooks.Open(Filename:=DirLoc & CurFile, ReadOnly:=True)

    ' Limit to valid sheet names and remove .xls*
    CurFile = Left(Left(CurFile, Len(CurFile) - 5), 29)

        OrigWb.Sheets.Copy After:=DestWb.Sheets(DestWb.Sheets.Count)
    'Name the File

        DestWb.Sheets(DestWb.Sheets.Count).Name = CurFile
    'Delete unwanted columns
        DestWb.Sheets(DestWb.Sheets.Count).Range("A:C,H:P").Delete (xlToLeft)
                OrigWb.Close SaveChanges:=False
        CurFile = Dir
       ' Set wbkOpen = Workbooks.Open(DirLoc & CurFile, False, True)




Loop

Application.DisplayAlerts = False
    DestWb.Sheets(1).Delete
Application.DisplayAlerts = True

Application.ScreenUpdating = True
Application.EnableEvents = True

Set DestWb = Nothing

End Sub

ASH ASH · Accepted Answer · 2017-01-28T18:00:14

You can use this method.

Sub combine()

    Dim app As New Excel.Application
    app.Visible = False

    Dim wbM As Workbook
    Set wbM = ActiveWorkbook

    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    fd.AllowMultiSelect = True
    Files = fd.Show

    For i = 1 To fd.SelectedItems.Count
        app.Workbooks.Open fd.SelectedItems(i)
    Next i

    Dim wb As Workbook
    For Each wb In app.Workbooks
        If wb.Name <> "main.xlsb" Then
            Dim wsN As Worksheet
            Set wsN = wbM.Sheets.Add(after:=wbM.Sheets(wbM.Sheets.Count))
            wsN.Name = wb.Name

            wbM.Sheets(wb.Name).Range("A1:K10").Value = wb.Sheets(1).Range("A1:K10").Value

            wb.Close SaveChanges:=False
        End If
    Next

    app.Quit
    Set app = Nothing

End Sub

Also, try the AddIn below.

http://www.rondebruin.nl/win/addins/rdbmerge.htm

Combine Excel workbooks into one master file copy using ranges

1 Answers