寻找将未保存的Excel工作簿合并为合并工作簿的VBA代码

Question

我有一个代码，它吐出了一个时间表的多个副本，其中包含不同的数据块。Excel将它们命名为"book1, book2"等。我正在寻找一种方法，将所有这些未保存的工作簿合并到一个合并的工作簿，而不必首先将它们保存在文件夹位置。我一直试图调整下面的代码，但它不做我想要的。如果你能帮忙，请告诉我

Sub MergeSheets2()
'Updated by Extendoffice 2019/2/20
Dim xStrPath As String
Dim xStrFName As String
Dim xWS As Worksheet
Dim xMWS As Worksheet
Dim xTWB As Workbook
Dim xStrAWBName As String
Dim xI As Integer

On Error Resume Next 
xStrPath = " C:UsersDT168DesktopKTE"
xStrName = "Book1,Book2,Book3,Book4"
xArr = Split(xStrName, ",")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set xTWB = ThisWorkbook
xStrFName = Dir(xStrPath & "*.xlsx")

Do While Len(xStrFName) > 0
Workbooks.Open Filename:=xStrPath & xStrFName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
For Each xWS In ActiveWorkbook.Sheets
For xI = 0 To UBound(xArr)
If xWS.Name = xArr(xI) Then
xWS.Copy After:=xTWB.Sheets(xTWB.Sheets.count)
Set xMWS = xTWB.Sheets(xTWB.Sheets.count)
xMWS.Name = xStrAWBName & "(" & xArr(xI) & ")"
Exit For
End If
Next xI
Next xWS
Workbooks(xStrAWBName).Close
xStrFName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Answer 1

这将创建一个新工作簿，然后将现有工作簿中名为Book1, Book2等的所有工作表复制到新工作簿中。它不检查工作簿是否实际存在。根据您创建的图书数量调整循环的大小。

它不会在拷贝到工作表后保存新的图书，也不会删除创建wbAll时存在的工作表，也不会在将工作表复制到wbAll时检查以确保没有工作表名称冲突。

您将需要实现所有这些检查。此外，在我看来，你的书不太可能总是被命名为Book1、Book2、Book3、Book4等。新书的编号是连续的，在Excel打开的整个过程中，它一直在增加，所以前四本书将被称为1、2、3、4，但接下来的四本书将被称为5、6、7、8。最好是跟踪已创建的图书的名称(或对实际图书的引用)，然后直接使用这些名称，而不是事后尝试构造名称。

Sub joinBooks()

Dim wb As Workbook, wbAll As Workbook
Dim ws As Worksheet

Set wbAll = Workbooks.Add
For t = 1 To 4

Set wb = Workbooks("Book" & t)
For Each ws In wb.Sheets                
ws.Copy after:=wbAll.Sheets(Sheets.Count)                
Next

Next

End Sub

Answer 2

Option Explicit
Sub MergeSheets2()
Const FOLDER = "C:UsersDT168DesktopKTE"

Dim sFName As String, x as String, n As Integer
Dim wb As Workbook, wbAll As Workbook
Dim ws As Worksheet
Set wbAll = Workbooks.Add(xlWBATWorksheet) ' 1 sheet
n = 1
Application.ScreenUpdating = False
sFName = Dir(FOLDER & "Book*.xlsx")
Do While Len(sFName) > 0
x = Mid(sFName, 5, Len(sFName) - 9)
If IsNumeric(x) Then

Set wb = Workbooks.Open(FOLDER & sFName, 1, 1)
For Each ws In wb.Sheets
ws.Copy after:=wbAll.Sheets(n)
n = n + 1
wbAll.Sheets(n).Name = "Book" & x & "_" & ws.Name
Next
wb.Close False
End If
sFName = Dir
Loop
With Application
.DisplayAlerts = False
wbAll.Sheets(1).Delete ' first blank sheet
.DisplayAlerts = True
.ScreenUpdating = False
End With
wbAll.SaveAs FOLDER & "Combined.xlsx"
MsgBox n - 1 & " sheets copied to " & wbAll.Name, vbInformation
End Sub