将来自多个工作簿的数据与多个工作表合并为摘要工作簿

Question

我有一个代码，它将来自多个工作簿（但仅限于一张工作表）的数据合并到摘要工作簿中。我正在努力改变它的代码与多个工作表的多个工作簿，但不能这样做。您可以请帮忙：

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 

Answer 1

正如蒂姆指出的，目前还不清楚您特别需要帮助。但是，我在下面包含的代码应该为您提供一个饼干切割器基座，您可以根据自己的目的带走和定制基座。我测试过了，它似乎运作良好。它将遍历您选择的一系列工作簿以及其中包含的所有工作表。

我希望这有助于

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 

Answer 2

如果你希望做一个总结了几个工作表，但不是工作簿，我会建议你检查这个procedure，在详细介绍如何创建自己的代码适应你的要求说。

因为大多数情况下，如果您要求某人修复您的代码，您将无法调试它或在将来修改它，因为它通常是这种情况。