用于将多个 Excel 工作表合并为一张工作表的 VBA 脚本
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/23157296/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
VBA script to consolidate multiple excel sheets into one sheet
提问by nadz
Im looking for a VBA script to consolidate multiple Excel sheets into one sheet in a different folder location with the name "consolidated.xlsx". I feel this is a rather simple VBA script but I tried creating a few from.the web and it didnt work. Any help would be appreciated. Thanks
我正在寻找一个 VBA 脚本来将多个 Excel 工作表合并到一个名为“consolidated.xlsx”的不同文件夹位置中的一个工作表中。我觉得这是一个相当简单的 VBA 脚本，但我尝试从 .the web 创建一些，但没有奏效。任何帮助，将不胜感激。谢谢
EDIT: I have this code that does consolidation, but its a bit complicated. How can I integrate this into your code "Consolidation part". I already wrote the code for opening the Target workbook but not sure how the loop will work to read All the available data and consolidate them into my target sheet (leaving any blank fields). Maybe the code below will help:
编辑：我有这段代码可以进行合并，但有点复杂。我如何将其集成到您的代码“整合部分”中。我已经编写了用于打开 Target 工作簿的代码，但不确定循环将如何工作以读取所有可用数据并将它们合并到我的目标表中（留下任何空白字段）。也许下面的代码会有所帮助：
Sub test()
Dim m1, Filenamev, Filenamev2 As String
Dim loopvar, i As Integer
m1 = Sheets("Sheet2").Range("c2")
mm1 = Sheets("Sheet2").Range("b2")
loopvar = Sheet2.Cells(1, 5)
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Clear
Workbooks.Open Filename:=m1, ReadOnly:=True
Sheets("sheet1").Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("MultiSheetPaste.xlsm").Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
False, Transpose:=False
'Windows("DAta1.xlsx").Activate
Application.DisplayAlerts = False
Workbooks(mm1).Close
i = 1
Do While i <= loopvar - 1
Filenamev = Sheet2.Cells(i + 2, 3)
Filenamev2 = Sheet2.Cells(i + 2, 2)
Workbooks.Open Filename:=Filenamev, ReadOnly:=True
Sheets("sheet1").Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("MultiSheetPaste.xlsm").Activate
Range("A1").Select
Selection.End(xlDown).Select
Dim m As String
m = ActiveCell.Row
'MsgBox "m"
Range("a" & m + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Windows("DAta2.xlsx").Activate
Application.DisplayAlerts = False
Workbooks(Filenamev2).Close
i = i + 1
Loop
End Sub
回答by Dan Wagner
Here is a jumping off point. The code below will prompt a user to select a file(s) [you can see that multi-select is enabled], then iterate over that selection. I think you'll be able to fill-in the blanks from there:
这是一个起点。下面的代码将提示用户选择一个文件[您可以看到多选已启用]，然后遍历该选择。我认为您可以从那里填写空白：
Option Explicit
Sub OpeningFiles()
Dim SelectedFiles As FileDialog
Dim NumFiles As Long, FileIndex As Long
Dim TargetBook As Workbook
'prompt user to select a file or multiple files
Set SelectedFiles = Application.FileDialog(msoFileDialogOpen)
With SelectedFiles
.AllowMultiSelect = True
.Title = "Pick the files you'd like to consolidate:"
.ButtonName = ""
.Filters.Clear
.Filters.Add ".xlsx files", "*.xlsx"
.Show
End With
'check to see if user clicked cancel
If SelectedFiles.SelectedItems.Count = 0 Then Exit Sub
'start the loop over each file
NumFiles = SelectedFiles.SelectedItems.Count
For FileIndex = 1 To NumFiles
'set a reference to the target workbook
Set TargetBook = Workbooks.Open(SelectedFiles.SelectedItems(FileIndex))
'do your consolidating here
'...
TargetBook.Close SaveChanges:=False
Next FileIndex
MsgBox ("Consolidation complete!")
End Sub
