使用VBA將多個文件複製到單個文件

Question

我正嘗試在窗體應用程序中編寫代碼，其中我可以選擇多個文件並將所有選定文件的數據追加到另一個文件（主文件）中。

下面我寫了一個函數，調用單擊Userform按鈕。

同時運行此代碼我收到自動化錯誤-2147221080（800401a8）

在調試時，我發現它在給錯誤在下面的代碼行

設置rngData = shtData重新分配值。 UsedRange

有人可以幫我解決這個問題，我是新來的VBA，並沒有得到錯誤的原因。

Function copyfiles() 
Dim wbkMaster As Workbook 
Dim shtMaster As Worksheet 
Dim rngMaster As Range 
Dim wbkData As Workbook 
Dim shtData As Worksheet 
Dim rngData As Range 
Dim intChoice As Integer 
Dim strPath As String 
Dim strPath1 As String 
Dim array1() As String 
Dim filepath As String 
Dim count As Integer 
Dim i As Integer 

'to select master file 

Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False 
intChoice = Application.FileDialog(msoFileDialogOpen).Show 
If intChoice <> 0 Then 
strPath = Application.FileDialog(_ 
msoFileDialogOpen).SelectedItems(1) 
End If 

Set wbkMaster = Workbooks.Open(strPath) 
Set shtMaster = wbkMaster.Worksheets(1) 



'to select source file(s) 
    Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = True 

    intChoice = Application.FileDialog(msoFileDialogOpen).Show 

    If intChoice <> 0 Then 
    For i = 1 To Application.FileDialog(msoFileDialogOpen _ 
).SelectedItems.count 
strPath = Application.FileDialog(msoFileDialogOpen _ 
).SelectedItems(i) 
filepath = filepath & strPath & "," 
Next i 
End If 

array1 = Split(filepath, ",", -1, vbBinaryCompare) 
count = i - 1 
Set rngMaster = shtMaster.Range("A65536").End(xlUp).Offset(1, 0) 
For j = 0 To count - 1 

Set wbkData = Workbooks.Open(array1(j)) 
Set shtData = wbkData.Worksheets(1) 
Set wbkMaster = Workbooks.Open(strPath) 
Set shtMaster = wbkMaster.Worksheets(1) 
Set rngData = shtData.UsedRange 

' copy data across 
rngData.Copy rngMaster 

' simply close data 
wbkData.Close False 

' release objects 
Set rngData = Nothing 
Set shtData = Nothing 
Set wbkData = Nothing 

wbkMaster.Close True 

Set shtMaster = Nothing 

Set wbkMaster = Nothing 

Next 

    Set rngMaster = Nothing 
End Function 

Answer 1

我想你應該試試Ron deBruin的代碼。

Sub Basic_Example_1() 
    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 

    'Fill in the path\folder where the files are 
    MyPath = "C:\Users\Ron\test" 

    '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 

    'Add a new workbook with one sheet 
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 
    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)) 
      On Error GoTo 0 

      If Not mybook Is Nothing Then 

       On Error Resume Next 

       With mybook.Worksheets(1) 
        Set sourceRange = .Range("A1:C1") 
       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 
         With sourceRange 
          BaseWks.cells(rnum, "A"). _ 
            Resize(.Rows.Count).Value = MyFiles(Fnum) 
         End With 

         '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 
       mybook.Close savechanges:=False 
      End If 

     Next Fnum 
     BaseWks.Columns.AutoFit 
    End If 

ExitTheSub: 
    'Restore ScreenUpdating, Calculation and EnableEvents 
    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
     .Calculation = CalcMode 
    End With 
End Sub 

Function RDB_Last(choice As Integer, rng As Range) 
'Ron de Bruin, 5 May 2008 
' 1 = last row 
' 2 = last column 
' 3 = last cell 
    Dim lrw As Long 
    Dim lcol As Integer 

    Select Case choice 

    Case 1: 
     On Error Resume Next 
     RDB_Last = rng.Find(What:="*", _ 
          after:=rng.cells(1), _ 
          Lookat:=xlPart, _ 
          LookIn:=xlFormulas, _ 
          SearchOrder:=xlByRows, _ 
          SearchDirection:=xlPrevious, _ 
          MatchCase:=False).Row 
     On Error GoTo 0 

    Case 2: 
     On Error Resume Next 
     RDB_Last = rng.Find(What:="*", _ 
          after:=rng.cells(1), _ 
          Lookat:=xlPart, _ 
          LookIn:=xlFormulas, _ 
          SearchOrder:=xlByColumns, _ 
          SearchDirection:=xlPrevious, _ 
          MatchCase:=False).Column 
     On Error GoTo 0 

    Case 3: 
     On Error Resume Next 
     lrw = rng.Find(What:="*", _ 
         after:=rng.cells(1), _ 
         Lookat:=xlPart, _ 
         LookIn:=xlFormulas, _ 
         SearchOrder:=xlByRows, _ 
         SearchDirection:=xlPrevious, _ 
         MatchCase:=False).Row 
     On Error GoTo 0 

     On Error Resume Next 
     lcol = rng.Find(What:="*", _ 
         after:=rng.cells(1), _ 
         Lookat:=xlPart, _ 
         LookIn:=xlFormulas, _ 
         SearchOrder:=xlByColumns, _ 
         SearchDirection:=xlPrevious, _ 
         MatchCase:=False).Column 
     On Error GoTo 0 

     On Error Resume Next 
     RDB_Last = rng.Parent.cells(lrw, lcol).Address(False, False) 
     If Err.Number > 0 Then 
      RDB_Last = rng.cells(1).Address(False, False) 
      Err.Clear 
     End If 
     On Error GoTo 0 

    End Select 

端功能

從這裏。

https://www.rondebruin.nl/win/s3/win008.htm

而且，試試這個外接程序。

https://www.rondebruin.nl/win/addins/rdbmerge.htm