Merging Multiple Workbooks into Single Sheet

Question

I'm trying to merge multiple Excel workbooks into a single sheet.

I found code to choose the folder and merge all the Excel files in the folder into current active workbook.

The target workbook consists of two sheets which is PID and Services.

Option Explicit
Public strPath As String

Public Type SELECTINFO
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

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 SELECTINFO) As Long

Function SelectFolder(Optional Msg) As String
Dim sInfo As SELECTINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
sInfo.pidlRoot = 0&

If IsMissing(Msg) Then
    sInfo.lpszTitle = "Select your folder."
Else
    sInfo.lpszTitle = Msg
End If

sInfo.ulFlags = &H1

x = SHBrowseForFolder(sInfo)

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

' "Merging Part"
Sub MergeExcels()
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
Dim RowofCopySheet As Integer

RowofCopySheet = 1 

ThisWB = ActiveWorkbook.Name

path = SelectFolder("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(RowofCopySheet, 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 "Files Merged!"
End Sub

I need to copy Sheet1 (PID) and Sheet2 (Services). The code merges sheet1 (PID) only.

I tried to tweak the code.

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(RowofCopySheet, 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

I tried to change
ActiveWorkbook.Sheets(1) to ActiveWorkbook.Sheets(2) and
Set CopyRng = Wkb.Sheets(1) to Set CopyRng = Wkb.Sheets(2).

How do the sheets look? How are you merging (appending to bottom, on right hand side)? Some data and desired results can help illustrate. — Parfait
hi @Parfait thanks btw. found the solution. just added 1 line code. the answer as below — MG78

MG78 MG78 · Accepted Answer · 2016-12-15T03:47:16

after tweaking and testing the code, i managed to find the way. The solution is just add "Wkb.Sheets(2).Activate" and the change Set CopyRng = Wkb.Sheets(1) to Set CopyRng = Wkb.Sheets(2) to merge the second sheet. Below are the sample code.

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

Merging Multiple Workbooks into Single Sheet

1 Answers