如何將數據追加到現有工作簿的工作表並且不創建新的工作簿

Question

我正在嘗試解決以下VBA代碼中需要更改的內容，以便在工作簿中已存在的數據底部追加數據命名爲 「主要」 和工作表命名爲 「總結」：

Sub MergeAllWorkbooks() 
Dim MyPath As String, FilesInPath As String 
Dim MyFiles() As String 
Dim SourceRcount As Long, FNum As Long 
Dim mybook As Workbook, BaseWks As Worksheet 
Dim sourceRange As Range, destrange As Range 
Dim rnum As Long, CalcMode As Long 

' Change this to the path\folder location of your files. 
MyPath = "C:\test\" 

' Add a slash at the end of the path if needed. 
If Right(MyPath, 1) <> "\" Then 
    MyPath = MyPath & "\" 
End If 

' If there are no Excel files in the folder, exit. 
FilesInPath = Dir(MyPath & "*.xl*") 
If FilesInPath = "" Then 
    MsgBox "No files found" 
    Exit Sub 
End If 

' Fill the myFiles array with the list of Excel files 
' in the search folder. 
FNum = 0 
Do While FilesInPath <> "" 
    FNum = FNum + 1 
    ReDim Preserve MyFiles(1 To FNum) 
    MyFiles(FNum) = FilesInPath 
    FilesInPath = Dir() 
Loop 
FNum = FNum - 1 

' Set various application properties. 
With Application 
    CalcMode = .Calculation 
    .Calculation = xlCalculationManual 
    .ScreenUpdating = False 
    .EnableEvents = False 
End With 

' Add a new workbook with one sheet. 
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 
rnum = 1 

' Loop through all files in the myFiles array. 
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)) 
     On Error GoTo 0 

     If Not mybook Is Nothing Then 
      On Error Resume Next 

      ' Change this range to fit your own needs. 
      With mybook.Worksheets(1) 
       Set sourceRange = .Range("A2:T" & CStr(mybook.Worksheets(1).Range("A2").CurrentRegion.Rows.Count)) 
      End With 

      If Err.Number > 0 Then 
       Err.Clear 
       Set sourceRange = Nothing 
      Else 
       ' If source range uses 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 "There are not enough rows in the target worksheet." 
        BaseWks.Columns.AutoFit 
        mybook.Close savechanges:=False 
        GoTo ExitTheSub 
       Else 

        ' Copy the file name in column A. 
        With sourceRange 
         BaseWks.Cells(rnum, "A"). _ 
           Resize(.Rows.Count).Value = MyFiles(FNum) 
        End With 

        ' Set the destination range. 
        Set destrange = BaseWks.Range("B" & rnum) 

        ' Copy the values from the source range 
        ' to the destination range. 
        With sourceRange 
         Set destrange = destrange. _ 
             Resize(.Rows.Count, .Columns.Count) 
        End With 
        destrange.Value = sourceRange.Value 

        rnum = rnum + SourceRcount 
       End If 
      End If 
      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

我不喜歡這個代碼。有很多我反對，但我最不滿意的使用錯誤處理：

• 錯誤處理功能是有允許出問題的時候你的日常優雅地失敗。這不是讓你忽略錯誤並繼續進行，好像它們沒有發生。

• 錯誤處理無法處理我的工作簿中的問題。我沒有調查，但我懷疑問題是單個單元的長度或由destrange.Value = sourceRange.Value傳輸的數據的總長度。

但是，你問怎麼做一個單一的改變，所以我會限制自己。

我建議最簡單的方法是用工作表「摘要」創建工作簿「主」，並在其中包含宏。

添加新語句下Dim語句：

Dim rnum As Long, CalcMode As Long 

    '### Start of new code  
    If Workbooks.Count > 1 Then 
    ' It is easy to get into a muddle if there are multiple workbooks 
    ' open at the start of a macro like this. Avoid the problem until 
    ' you understand it. 
    Call MsgBox("Please close all other workbooks", vbOKOnly) 
    Exit Sub 
    End If 

    Set BaseWks = ActiveWorkBook.Worksheets("Summary") 
    With BaseWks 
    rnum = .Cells(Rows.Count, "A").End(xlUp).Row + 1 
    End With 
'### End of new code 

' Change this to the path\folder location of your files. 

上面的代碼的第一個塊確保沒有其他工作簿打開。

第二個塊（1）將BaseWks設置爲工作表「摘要」並且（2）將rnum設置爲「摘要」中的第一個未使用的行。 End(xlUp)是點擊Ctrl + Up的VBA等效項。所以我已經走到了A列的底部，一直往上走，直到我連一個數值然後下了一行。

替換與所在的文件名的循環：

Do While FilesInPath <> "" 

    If FilesInPath <> ActiveWorkbook.Name Then 
     FNum = FNum + 1 
     ReDim Preserve MyFiles(1 To FNum) 
     MyFiles(FNum) = FilesInPath 
    End If 
    FilesInPath = Dir() 

    Loop 

我認爲工作簿「主」將在同一文件夾中的其他工作簿。此更改可確保「主」不被用作源。

丟棄這些語句：

Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 
rnum = 1 

，因爲我已經設置BaseWks和rnum到我所需要的值。

如果你想自動保存更新工作簿「主」，上面加ExitTheSub:以下語句：

ActiveWorkbook.Save