運行時錯誤將多個工作簿合併爲一個

Question

我試圖讓我的腳本將多個工作簿合併爲一個，但不工作。我的範圍設置爲我的一個文件中的最大記錄數，但實際上，我希望代碼進入每個文件，將單元格A3中的所有內容複製到右側和最後一行的最後一列，然後粘貼它下一個空行在我的主文件中。現在，當我運行它時，數據粘貼之間存在巨大差距。此外，我不想要任何格式更改，我想它只是粘貼。有人請幫忙，下面是我的代碼。

Private Declare Function SetCurrentDirectoryA Lib _ 
    "kernel32" (ByVal lpPathName As String) As Long 

Sub ChDirNet(szPath As String) 
    SetCurrentDirectoryA szPath 
End Sub 

Sub MergeSpecificWorkbooks() 
    Dim MyPath 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 
    Dim SaveDriveDir As String 
    Dim FName As Variant 


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

SaveDriveDir = CurDir 
' Change this to the path\folder location of the files. 
ChDirNet "F:\Documents\Files\Macro Folder" 

FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xlsx*), *.xlsx*", _ 
            MultiSelect:=True) 
If IsArray(FName) Then 

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


    ' Loop through all files in the myFiles array. 
    For FNum = LBound(FName) To UBound(FName) 
     Set mybook = Nothing 
     On Error Resume Next 
     Set mybook = Workbooks.Open(FName(FNum)) 
     On Error GoTo 0 

     If Not mybook Is Nothing Then 

      On Error Resume Next 
      With mybook.Worksheets(1) 
       Set sourceRange = .Range("A3:CE7771") 
      End With 

      If Err.Number > 0 Then 
       Err.Clear 
       Set sourceRange = Nothing 
      Else 
       ' If the 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 

        ' Set the destination range. 
        Set destrange = BaseWks.Range("A" & 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 
    ChDirNet SaveDriveDir 
End Sub 

Answer 1

嘗試是這樣的：

未經測試

Sub MergeSpecificWorkbooks() 

Dim SourceRcount As Long 
Dim rnum   As Long 
Dim i    As Long 
Dim lastRow   As Long 
Dim lastCol   As Long 
Dim BaseWks   As Worksheet 
Dim sourceRange  As Range 
Dim destrange  As Range 
Dim myFiles()  As Workbook 
Dim vrtSelectedItem As Variant 
Dim mybook   As Variant 

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

With Application.FileDialog(msoFileDialogOpen) 
    .Title = "Select Files to Merge" 
    .InitialFileName = "F:\Documents\Files\Macro Folder\" 
    .Filters.Add "Excel Files (*.xlsx)", "*.xlsx" 
    .AllowMultiSelect = True 
    .Show 
     If .SelectedItems.Count < 1 Then Exit Sub 
     ReDim myFiles(1 To .SelectedItems.Count) 
     For Each vrtSelectedItem In .SelectedItems 
      i = i + 1 
      Set myFiles(i) = Workbooks.Open(vrtSelectedItem) 
     Next 
End With 

If Not myFiles(1) Is Nothing Then 

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

    ' Loop through all files in the myFiles array. 
    For Each mybook In myFiles 
     With mybook.Sheets(1) 
      lastRow = .Range("A:A").Find("*", searchdirection:=xlPrevious).Row 
      lastCol = .Rows("3:3").Find("*", searchdirection:=xlPrevious).Column 
      Set sourceRange = .Range(.Cells(3, 1), .Cells(lastRow, lastCol)) 
     End With 

     SourceRcount = sourceRange.Rows.Count 

     If rnum + SourceRcount <= BaseWks.Rows.Count Then 
      ' Set the destination range. 
      With BaseWks 
       Set destrange = .Range(.Cells(rnum, 1), .Cells(rnum + SourceRcount, lastCol)) 
      End With 

      ' Copy the values from the source range to the destination range. 
      destrange.Value = sourceRange.Value 
      rnum = BaseWks.Range("A:A").Find("*", searchdirection:=xlPrevious).Row + 1 
     Else 
      'MsgBox "There are not enough rows in the target worksheet.", vbCritical 
      'Exit For 
      Set BaseWks = BaseWks.Parent.Sheets.Add 
      ' Set the destination range in the new sheet. 
      With BaseWks 
       Set destrange = .Range(.Cells(rnum, 1), .Cells(rnum + SourceRcount, lastCol)) 
      End With 

      ' Copy the values from the source range to the destination range. 
      destrange.Value = sourceRange.Value 
      rnum = BaseWks.Range("A:A").Find("*", searchdirection:=xlPrevious).Row + 1 
     End If 
    Next mybook 
    BaseWks.Columns.AutoFit 
End If 

'Close the opened workbooks. 
For Each mybook In myFiles 
    mybook.Close SaveChanges:=False 
Next mybook 

' Restore the application properties. 
With Application 
    .ScreenUpdating = True 
    .EnableEvents = True 
    .Calculation = xlCalculationAutomatic 
End With 

End Sub 

注意，我把它這樣，如果單充數據，創建一個新的工作表和數據被粘貼到新工作表上。如果你不想這樣做，只需在Else之後註釋/刪除代碼並取消註釋Msgbox和Exit For。