将多个工作表复制到VBA工作簿本身
下面的代码完美地将从SPECIFIED工作簿的活动工作表的数据复制到一个新的未命名的工作簿。 它复制第一个文件的第一行，并将除第一个（标题）行之外的其他文件的数据与它结合。
但是，我正在学习，我想知道如何将数据以相同的方式结合到macros观工作簿本身（而不是在新的工作簿中）。 我打算做一些macros观logging后，数据是在同一个macros本内。
请帮我怎么做到这一点。 我尝试将新工作簿（运行下面的代码后生成的工作簿）的组合工作表复制到macros工作簿中，然后closures新工作簿而不保存它，但迄今为止没有成功。 请帮忙。
Option Explicit Sub CombineDataFiles() Dim DataBook As Workbook, OutBook As Workbook Dim DataSheet As Worksheet, OutSheet As Worksheet Dim TargetFiles As FileDialog Dim MaxNumberFiles As Long, FileIdx As Long, _ LastDataRow As Long, LastDataCol As Long, _ HeaderRow As Long, LastOutRow As Long Dim DataRng As Range, OutRng As Range 'initialize constants MaxNumberFiles = 2001 HeaderRow = 1 'assume headers are always in row 1 LastOutRow = 1 'prompt user to select files Set TargetFiles = Application.FileDialog(msoFileDialogOpen) With TargetFiles .AllowMultiSelect = True .Title = "Multi-select target data files:" .ButtonName = "" .Filters.Clear .Filters.Add ".xlsx files", "*.xlsx" .Show End With 'error trap - don't allow user to pick more than 2000 files If TargetFiles.SelectedItems.Count > MaxNumberFiles Then MsgBox ("Too many files selected, please pick more than " & MaxNumberFiles & ". Exiting sub...") Exit Sub End If 'set up the output workbook Set OutBook = Workbooks.Add Set OutSheet = OutBook.Sheets(1) 'loop through all files For FileIdx = 1 To TargetFiles.SelectedItems.Count 'open the file and assign the workbook/worksheet Set DataBook = Workbooks.Open(TargetFiles.SelectedItems(FileIdx)) Set DataSheet = DataBook.ActiveSheet 'identify row/column boundaries LastDataRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row LastDataCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column 'if this is the first go-round, include the header If FileIdx = 1 Then Set DataRng = Range(DataSheet.Cells(HeaderRow, 1), DataSheet.Cells(LastDataRow, LastDataCol)) Set OutRng = Range(OutSheet.Cells(HeaderRow, 1), OutSheet.Cells(LastDataRow, LastDataCol)) 'if this is NOT the first go-round, then skip the header Else Set DataRng = Range(DataSheet.Cells(HeaderRow + 1, 1), DataSheet.Cells(LastDataRow, LastDataCol)) Set OutRng = Range(OutSheet.Cells(LastOutRow + 1, 1), OutSheet.Cells(LastOutRow + 1 + LastDataRow, LastDataCol)) End If 'copy the data to the outbook DataRng.Copy OutRng 'close the data book without saving DataBook.Close False 'update the last outbook row LastOutRow = OutSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Next FileIdx 'let the user know we're done! MsgBox ("Combined " & TargetFiles.SelectedItems.Count & " files!") End Sub 将OutBookvariables更改为引用ThisWorkbook ，并将OutSheet更改为此工作簿中的工作表。
'set up the output workbook Set OutBook = ThisWorkbook `Workbooks.Add
您可能要添加一个新工作表：
Set OutSheet = OutBook.Sheets.Add OutSheet.Name = "CombineDataFilesOutput"
如果您经常这样做，您可能需要给工作表一个唯一的ID，以便您可以添加倍数，而不必担心重复的工作表名称。 我通常使用Now()某种格式来创build一个唯一的标识符：
OutSheet.Name = Format(Now(),"YYYYMMDDhhmmss")
我也注意到你对文件select限制的评论似乎误告知用户。 你告诉他们“请select2000多个文件”，但应该说“请select不超过2000个文件”，甚至更好“请select不超过2000个文件”。
'error trap - don't allow user to pick more than 2000 files If TargetFiles.SelectedItems.Count > MaxNumberFiles Then MsgBox ("Too many files selected, please pick less than " & MaxNumberFiles & ". Exiting sub...") Exit Sub End If