Excel VBA – 将多个工作簿合并到一张表中

我正在尝试将多个Excel工作簿合并到一个工作表中。 我find了其他网站的代码，并设法select文件夹，并将文件夹中的所有excel文件合并到当前活动工作簿中。 目标工作簿由2个PID和服务表组成。 以下是代码：

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 

我的工作簿需要首先复制Sheet1（PID），第二个操作需要复制Sheet2（服务）。但是，我发现的代码只合并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

在调整和testing代码后，我设法find了方法。 解决scheme是只添加“Wkb.Sheets（2）.Activate”和更改设置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