Excel VBA - 将多个工作簿合并为单张

我想将多个Excel工作簿合并到一张工作表中。我找到了其他网站的代码，并设法选择该文件夹并将该文件夹中的所有excel文件合并到当前活动工作簿中。目标工作簿包含2张PID和服务表。下面是代码：Excel VBA - 将多个工作簿合并为单张

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），但没有运气。希望你们能帮助我。谢谢

来源

2016-12-15 Jeeva

床单的外观如何？你怎么合并*（追加到底部，在右边）？一些数据和期望的结果可以帮助说明。 – Parfait

嗨@Parfait感谢btw。找到了解决方案。刚刚添加了1行代码。答案如下 – Jeeva

经过调整和测试的代码，我设法找到方式。解决方案是只需添加“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

来源

2016-12-15 03:47:16 Jeeva

Excel VBA - 将多个工作簿合并为单张

回答

相关问题