我有一个代码，它将来自多个工作簿的数据（但只有一个工作表）组合成摘要工作簿。我正在努力使用代码来为具有多个工作表的多个工作簿更改它但不能这样做。你能帮忙吗？
Sub MergeAllWorkbooks()
Dim myPath As String, FilesInPath As String, lastrow As String
Dim MyFiles() As String
Dim SourceRcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet, mysht As Worksheet
Dim sourceRange As Range, destRange As Range
Dim rnum As Long, CalcMode As Long
Dim i As Integer, j As Integer
'Fill in the path\folder where the files are
myPath = ThisWorkbook.Path & "\Some"
'Add a slash at the end if the user forget it
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = dir(myPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = dir()
Loop
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
Set BaseWks = ThisWorkbook.Worksheets(3)
rnum = 1
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(myPath & MyFiles(Fnum))
Set mysht = mybook.Worksheet
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
'For i = 1 To Worksheets(i).Count
'LastRow = Worksheets(i).Range("F" & rows.Count).End(xlUp).Row
'MsgBox LastRow
With mybook.Worksheets(1)
Set sourceRange = Range("A6:I100") ' & LastRow)
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceRcount = sourceRange.rows.Count
If rnum + SourceRcount >= BaseWks.rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
BaseWks.Columns.AutoFit
mybook.Close SaveChanges:=False
GoTo ExitTheSub
Else
'Copy the file name in column A
'For j = 1 To Worksheets(j).Count 'Worksheets.Count
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.rows.Count).Value = Range("A2").Value 'MyFiles(Fnum)
End With
'Next j
'Set the destrange
Set destRange = BaseWks.Range("B" & rnum)
'we copy the values from the sourceRange to the destrange
With sourceRange
Set destRange = destRange. _
Resize(.rows.Count, .Columns.Count)
End With
destRange.Value = sourceRange.Value
rnum = rnum + SourceRcount
End If
End If
'Next i
mybook.Close SaveChanges:=False
End If
Next Fnum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
答案 0 :(得分：0)
正如蒂姆亲切地指出的那样，目前还不清楚你特别需要帮助的是什么。但是，我在下面提供的代码应该为您提供一个 cookie-cutter 基础，您可以将其带走并根据您的目的进行自定义。我测试了它，它似乎运作良好。它将遍历您选择的一系列工作簿以及其中包含的所有工作表。
我希望这会有所帮助
P.S对于乱码我很抱歉 - 我没有时间清理它。
Sub MergeMultiple1()
Dim sh As Excel.Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
' Delete the summary sheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
' Add a new summary worksheet.
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
' Fill in the start row.
currentfiles = selectedfiles()
For nfile = LBound(currentfiles) To UBound(currentfiles)
Set oFS = CreateObject("scripting.filesystemobject")
Filename = currentfiles(nfile)
Set workbk1 = Workbooks.Open(Filename)
StartRow = 1
' Loop through all worksheets and copy the data to the
For Each sh In ActiveWorkbook.Worksheets
'Set sh = ActiveWorkbook.Worksheets(1)
If sh.Name <> DestSh.Name Then
' Find the last row with data on the summary
' and source worksheets.
Last = LastRow(DestSh)
shLast = LastRow(sh)
' If source worksheet is not empty and if the last
' row >= StartRow, copy the range.
If shLast > 0 And shLast >= StartRow Then
'Set the range that you want to copy
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
' Test to see whether there are enough rows in the summary
' worksheet to copy all the data.
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the " & _
"summary worksheet to place the data."
GoTo ExitTheSub
End If
' This statement copies values and formats.
CopyRng.Copy
rnga = DestSh.Cells(Last + 1, "A")
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
DestSh.Cells(Last + 1, "X").Value = workbk1.Name
End If
End If
Next
workbk1.Close
Next
ExitTheSub:
Application.GoTo DestSh.Cells(1)
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Function
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Function selectedfiles()
selectedfiles = Application.GetOpenFilename( _
filefilter:="Speadsheets, *.xl*; *.csv", MultiSelect:=True)
End Function
答案 1 :(得分：0)
如果您希望从多个工作表而不是工作簿中进行总结，我建议您查看procedure，详细说明如何根据您的请求创建自己的代码。
因为大多数时候，如果你要求某人修改你的代码，你将无法调试它或将来修改它，因为通常就是这种情况。