Excel VBA - Объединение нескольких рабочих книг в один лист

Question

Я пытаюсь объединить несколько книг excel в один лист. Я нашел код с другого сайта, и ему удалось выбрать папку и объединить все файлы excel в папке в текущую активную книгу. Целевые книги состоят из 2 листов, которые являются PID и 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 

Моя рабочая тетрадь нужно сначала скопировать Лист1 (PID), и второе действие нужно скопировать Лист2 (услуги) .Однако только код, который я нашел только сливаться sheet1 (PID). Я попытался настроить код, но не повезло. Ниже часть я попытался настроить:

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 

Я попытался изменить ActiveWorkbook.Sheets (1) ActiveWorkbook.Sheets (2) и набор CopyRng = Wkb.Sheets (1) Установка CopyRng = Wkb.Sheets (2), но не повезло. Надеюсь, вы, ребята, можете мне помочь. Спасибо

Answer 1

после настройки и тестирования кода мне удалось найти способ. Решение просто добавляет «Wkb.Sheets (2) .Activate» и изменение Set CopyRng = Wkb.Sheets (1) для установки CopyRng = Wkb.Sheets (2) для объединения второго листа. Ниже приведен пример кода.

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