select范围单元格以从多个工作簿复制时出错

根据dwirony的意见更新：

我试图创build一个代码，从多个工作簿中的相同单元复制信息，并将这些信息合并到一个摘要工作簿中。 下面的代码按照书面forms工作，但是，如果向sourceRange添加更多单元格地址（从第69行开始），macros仍然运行，但是没有信息被复制到新的摘要工作簿中。

原问题：

我试图从一个文件夹中的多个工作表中select相同的特定单元格，并将它们合并到一个主电子表格中。 该代码工作到一定数量的单元格，但是如果我尝试包括更多，macros返回一个空白的工作簿（除了我分配的列标题）。 如果select的单元太多，那么最初工作的单元将无法工作。 即在下面显示的代码中，单元格J2是调用的第一个和最后一个单元，程序将运行。 如果我再次添加J2，（范围结束… J2，J2“）或任何其他单元格，似乎我已经达到了某个地方的限制，我得到一个空白的工作簿。

我以前没有使用过VBA和macros的经验，我所做的一切都来自各种互联网和内部资源。 也许多个来源是错误的来源？

任何帮助将不胜感激！

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 Dim a As Range, c As Range Dim x As Long ' Change this to the path\folder location of your files. MyPath = "C:\Users\amiller\OneDrive - CoorsTek\temp" ' 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 & "*.xls*") 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 ' 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("J2, C2, D7, F7, K7, G10, J10, G11, J11, G12, J12, G14, J14, G15, J15, G16, J16, G17, J17, J21," _ & "J2, D24, E24, G24, I24, J24, O24, P24, Q24, R24, S24, D25, E25, G25, I25, J25, O25, P25, Q25, R25, S25," _ & "D26, E26, G26, I26, J26, O26, P26, Q26, R26, S26, D27, J2") 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 + 1, "A"). _ Resize(.Rows.Count).Value = MyFiles(FNum) End With ' Set the destination range. Set destrange = BaseWks.Range("B" & rnum + 1) x = 0 For Each a In sourceRange.Areas For Each c In a.Cells x = x + 1 destrange.Offset(0, x - 1).Value = c.Value Next c Next a ' 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