將來自多個工作簿的數據與多個工作表合併爲摘要工作簿

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，在詳細介紹如何創建自己的代碼適應你的要求說。

因爲大多數情況下，如果您要求某人修復您的代碼，您將無法調試它或在將來修改它，因爲它通常是這種情況。