您的位置: 首页  >  技术问答  >  如何将数据追加到现有工作簿的工作表并且不创建新的工作簿

如何将数据追加到现有工作簿的工作表并且不创建新的工作簿

分类: 技术问答 • 2022-05-28 12:57:05
问题描述：

我正在尝试解决以下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

谢谢

答

我不喜欢这个代码。有很多我反对，但我最不满意的使用错误处理：

  • 错误处理功能是有允许出问题的时候你的日常优雅地失败。这不是让你忽略错误并继续进行，好像它们没有发生。

  • 错误处理无法处理我的工作簿中的问题。我没有调查，但我怀疑问题是单个单元的长度或由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

相关推荐