合并来自不同 Excel 工作簿的数据答案

【问题标题】：Merging data from different excel workbooks合并来自不同 Excel 工作簿的数据
【发布时间】：2016-09-06 10:59:45
【问题描述】：

首先，在编码方面，我是一个新手，但我正在尝试看看它如何帮助我深入挖掘我的数据。

我目前正在考虑为不同的团队成员捕获时间表数据并将其复制到主摘要工作簿中。

我录制了我的宏，然后重新组织了一些东西以使代码更清晰（这可能是我出错的地方）。但是现在当我运行我的宏时，我得到一个运行时错误“9”：下标超出范围。

我的代码如下：

Option Explicit

Sub MergeAll()

' Open all Timesheets

Workbooks.Open Filename:= _
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_JAMAL.xlsx"
Workbooks.Open Filename:= _
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_LOKESH.xlsx"
Workbooks.Open Filename:= _
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_NONI.xlsx"
Workbooks.Open Filename:= _
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_RAJESH.xlsx"
Workbooks.Open Filename:= _
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_SANTHOSH.xlsx"
Workbooks.Open Filename:= _
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_7.xlsx"
Workbooks.Open Filename:= _
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_8.xlsx"
Workbooks.Open Filename:= _
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_9.xlsx"

'  Activate and Copy Data

Windows("2016_JAMAL.xlsx").Activate
Range("G2:J2").Select
Selection.Copy
Windows("master.xlsm").Activate
Range("C2:F2").Select
ActiveSheet.Paste

Windows("2016_LOKESH.xlsx").Activate
Range("G2:J2").Select
Selection.Copy
Windows("master.xlsm").Activate
Range("C2:F2").Select
ActiveSheet.Paste

Windows("2016_NONI.xlsx").Activate
Range("G2:J2").Select
Selection.Copy
Windows("master.xlsm").Activate
Range("C2:F2").Select
ActiveSheet.Paste

Windows("2016_RAJESH.xlsx").Activate
Range("G2:J2").Select
Selection.Copy
Windows("master.xlsm").Activate
Range("C2:F2").Select
ActiveSheet.Paste

Windows("2016_SANTHOSH.xlsx").Activate
Range("G2:J2").Select
Selection.Copy
Windows("master.xlsm").Activate
Range("C2:F2").Select
ActiveSheet.Paste

Windows("2016_WARREN.xlsx").Activate
Range("G2:J2").Select
Selection.Copy
Windows("master.xlsm").Activate
Range("C2:F2").Select
ActiveSheet.Paste

Windows("2016_7.xlsx").Activate
Range("G2:J2").Select
Selection.Copy
Windows("master.xlsm").Activate
Range("C2:F2").Select
ActiveSheet.Paste

Windows("2016_8.xlsx").Activate
Range("G2:J2").Select
Selection.Copy
Windows("master.xlsm").Activate
Range("C2:F2").Select
ActiveSheet.Paste

Windows("2016_9.xlsx").Activate
Range("G2:J2").Select
Selection.Copy
Windows("master.xlsm").Activate
Range("C2:F2").Select
ActiveSheet.Paste

'  Close all Timesheets

Windows("2016_JAMAL.xlsx").Activate
ActiveWindow.Close

Windows("2016_LOKESH.xlsx").Activate
ActiveWindow.Close

Windows("2016_NONI.xlsx").Activate
ActiveWindow.Close

Windows("2016_RAJESH.xlsx").Activate
ActiveWindow.Close

Windows("2016_SANTHOSH.xlsx").Activate
ActiveWindow.Close

Windows("2016_WARREN.xlsx").Activate
ActiveWindow.Close

Windows("2016_7.xlsx").Activate
ActiveWindow.Close

Windows("2016_8.xlsx").Activate
ActiveWindow.Close

Windows("2016_9.xlsx").Activate
ActiveWindow.Close

End Sub

现在我取出了每行中出现的一些代码，在 Windows("filename").Activate 行之后。这是：

ActiveWindow.SmallScroll Down:=-18

因为我相信这只是当我向上滚动到正确的位置并且取决于每次保存之前哪个是活动单元格时，这会改变。

我没有想法，任何帮助将不胜感激。

为了记录，到目前为止，我已经尝试了几种不同的方法 - 包括从网站复制和粘贴代码，跟随你管教程视频，但每次和每种方法都会发生相同的错误。

提前致谢，

丰富

更新

我重新录制了宏，只是更改了录制过程中的顺序。我不再得到错误。但是，代码非常混乱且冗长。在此过程中，屏幕也会闪烁很多。有没有办法让它为用户提供更流畅的体验？新代码如下

    Sub MergeAll2()
'
' MergeAll2 Macro
'

'
' Open All

Workbooks.Open Filename:= _
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_7.xlsx"
Workbooks.Open Filename:= _
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_8.xlsx"
Workbooks.Open Filename:= _
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_9.xlsx"
Workbooks.Open Filename:= _
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_JAMAL.xlsx"
Workbooks.Open Filename:= _
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_LOKESH.xlsx"
Workbooks.Open Filename:= _
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_NONI.xlsx"
Workbooks.Open Filename:= _
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_RAJESH.xlsx"
Workbooks.Open Filename:= _
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_SANTHOSH.xlsx"
Workbooks.Open Filename:= _
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_WARREN.xlsx"

' Copy & Paste

Windows("2016_JAMAL.xlsx").Activate
Range("G2:J2").Select
Selection.Copy
Windows("master.xlsm").Activate
Range("C2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("2016_LOKESH.xlsx").Activate
Range("G2:J2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("master.xlsm").Activate
Range("C3:F3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("2016_NONI.xlsx").Activate
Range("G2:J2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("master.xlsm").Activate
Range("C4").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("2016_RAJESH.xlsx").Activate
Range("G2:J2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("master.xlsm").Activate
Range("C5").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("2016_SANTHOSH.xlsx").Activate
Range("G2:J2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("master.xlsm").Activate
Range("C6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("2016_WARREN.xlsx").Activate
Range("G2:J2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("master.xlsm").Activate
Range("C7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("2016_7.xlsx").Activate
Range("G2:J2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("master.xlsm").Activate
Range("C8").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("2016_8.xlsx").Activate
Range("G2:J2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("master.xlsm").Activate
Range("C9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("2016_9.xlsx").Activate
Range("G2:J2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("master.xlsm").Activate
Range("C10").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

' Close All

Windows("2016_JAMAL.xlsx").Activate
ActiveWindow.Close
Windows("2016_LOKESH.xlsx").Activate
ActiveWindow.Close
Windows("2016_NONI.xlsx").Activate
ActiveWindow.Close
Windows("2016_RAJESH.xlsx").Activate
ActiveWindow.Close
Windows("2016_SANTHOSH.xlsx").Activate
ActiveWindow.Close
Windows("2016_WARREN.xlsx").Activate
ActiveWindow.Close
Windows("2016_7.xlsx").Activate
ActiveWindow.Close
Windows("2016_8.xlsx").Activate
ActiveWindow.Close
Windows("2016_9.xlsx").Activate
ActiveWindow.Close
End Sub

更新 2

非常感谢到目前为止的帮助。我正在寻找编辑这一行：

Workbooks("master").ActiveSheet.Range("C2:F2").Value = Workbooks("2016_JAMAL").ActiveSheet.Range("G2:J2").Value

这样我就可以选择将其写入“master”中的哪个工作表以及从“2016_JAMAL”中的哪个工作表中复制它。

其次，我想从这张纸上的两个范围复制 - C2:G2 和 C5:G56 我想以一种精简的方式做到这一点。

非常感谢您到目前为止的回答 - 我将阅读有关数组的信息并完成 5 页！

丰富

【问题讨论】：

错误出现在哪一行？
嗨，Brian，感谢您回复我 - 我在上面发布了更新。
每个工作簿只有一张吗？
嗨，Brian - 他们没有，但如果需要，他们可以拥有。除了需要几个的master。

标签： excel vba merge macros

【解决方案1】：

您可以通过以下设置来停止闪烁的屏幕：

Application.ScreenUpdating = False

将它添加到您的宏中并再次运行它。

【讨论】：

谢谢 - 太好了。好多了！
确保在宏末尾再次输入Application.ScreenUpdating = True。

【解决方案2】：

您应该能够加快您的 “复制和粘贴” 部分的速度，而改为使用这个：

With Workbooks("master").ActiveSheet
    .Range("C2:F2").Value = Workbooks("2016_JAMAL").ActiveSheet.Range("G2:J2").Value
    .Range("C3:F3").Value = Workbooks("2016_LOKESH").ActiveSheet.Range("G2:J2").Value
    .Range("C4:F4").Value = Workbooks("2016_NONI").ActiveSheet.Range("G2:J2").Value
    .Range("C5:F5").Value = Workbooks("2016_RAJESH").ActiveSheet.Range("G2:J2").Value
    .Range("C6:F6").Value = Workbooks("2016_SANTHOSH").ActiveSheet.Range("G2:J2").Value
    .Range("C7:F7").Value = Workbooks("2016_WARREN").ActiveSheet.Range("G2:J2").Value
    .Range("C8:F8").Value = Workbooks("2016_7").ActiveSheet.Range("G2:J2").Value
    .Range("C9:F9").Value = Workbooks("2016_8").ActiveSheet.Range("G2:J2").Value
    .Range("C10:F10").Value = Workbooks("2016_9").ActiveSheet.Range("G2:J2").Value
End With

您还可以使用以下方法使您的 "close" 部分更简单：

Workbooks("2016_JAMAL.xlsx").Close False
Workbooks("2016_LOKESH.xlsx").Close False
Workbooks("2016_NONI.xlsx").Close False
Workbooks("2016_RAJESH.xlsx").Close False
Workbooks("2016_SANTHOSH.xlsx").Close False
Workbooks("2016_WARREN.xlsx").Close False
Workbooks("2016_7.xlsx").Close False
Workbooks("2016_8.xlsx").Close False
Workbooks("2016_9.xlsx").Close False

【讨论】：

甚至遍历工作簿名称的数组/集合。
确实，虽然通过宏录制我不想让它变得比 OP 容易理解的复杂。
感谢两位 - 这些都是很棒的 cmets。蒂姆——我一定会实施这些改变。 Parfait - 我很想学习 - 还有其他话题可以讨论您的观点吗？
Tim - 只是一个问题 - 我理解并欣赏复制和粘贴的逻辑，但我在工作簿末尾挣扎 False。关闭 - 你能解释一下这个语法吗？大脑可以更好地理解！ :-)
没问题。这意味着当我关闭时不要保存。如果它被留下，那么在某些情况下，您可能会被问到是否要保存工作簿。都很详细here.

【解决方案3】：

我使用Activesheet 不知道每个工作簿有多少张工作表或它们的名称。您可以进行相应的调整。这是我的版本：

Option Explicit

Sub MergeAll2()

Dim wb2016_7 As Workbook
Dim wb2016_8 As Workbook
Dim wb2016_9 As Workbook
Dim wb2016_JAMAL As Workbook
Dim wb2016_LOKESH As Workbook
Dim wb2016_NONI As Workbook
Dim wb2016_RAJESH As Workbook
Dim wb2016_SANTHOSH As Workbook
Dim wb2016_WARREN As Workbook
Dim strPath As String

Application.ScreenUpdating = False

strPath = "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\"

Set wb2016_7 = Workbooks.Open(Filename:=strPath & "2016_7.xlsx")
Set wb2016_8 = Workbooks.Open(Filename:=strPath & "2016_8.xlsx")
Set wb2016_9 = Workbooks.Open(Filename:=strPath & "2016_9.xlsx")
Set wb2016_JAMAL = Workbooks.Open(Filename:=strPath & "2016_JAMAL.xlsx")
Set wb2016_LOKESH = Workbooks.Open(Filename:=strPath & "2016_LOKESH.xlsx")
Set wb2016_NONI = Workbooks.Open(Filename:=strPath & "2016_NONI.xlsx")
Set wb2016_RAJESH = Workbooks.Open(Filename:=strPath & "2016_RAJESH.xlsx")
Set wb2016_SANTHOSH = Workbooks.Open(Filename:=strPath & "2016_SANTHOSH.xlsx")
Set wb2016_WARREN = Workbooks.Open(Filename:=strPath & "2016_WARREN.xlsx")

With Workbooks("master").ActiveSheet
    .Range("C2:F2").Value = wb2016_JAMAL.ActiveSheet.Range("G2:J2").Value
    .Range("C3:F3").Value = wb2016_LOKESH.ActiveSheet.Range("G2:J2").Value
    .Range("C4:F4").Value = wb2016_NONI.ActiveSheet.Range("G2:J2").Value
    .Range("C5:F5").Value = wb2016_RAJESH.ActiveSheet.Range("G2:J2").Value
    .Range("C6:F6").Value = wb2016_SANTHOSH.ActiveSheet.Range("G2:J2").Value
    .Range("C7:F7").Value = wb2016_WARREN.ActiveSheet.Range("G2:J2").Value
    .Range("C8:F8").Value = wb2016_7.ActiveSheet.Range("G2:J2").Value
    .Range("C9:F9").Value = wb2016_8.ActiveSheet.Range("G2:J2").Value
    .Range("C10:F10").Value = wb2016_9.ActiveSheet.Range("G2:J2").Value
End With

wb2016_7.Close True
wb2016_8.Close True
wb2016_9.Close True
wb2016_JAMAL.Close True
wb2016_LOKESH.Close True
wb2016_NONI.Close True
wb2016_RAJESH.Close True
wb2016_SANTHOSH.Close True
wb2016_WARREN.Close True

Set wb2016_7 = Nothing
Set wb2016_8 = Nothing
Set wb2016_9 = Nothing
Set wb2016_JAMAL = Nothing
Set wb2016_LOKESH = Nothing
Set wb2016_NONI = Nothing
Set wb2016_RAJESH = Nothing
Set wb2016_SANTHOSH = Nothing
Set wb2016_WARREN = Nothing

Application.ScreenUpdating = True

End Sub

使用Option Explicit 是一种很好的做法，它会强制您声明变量并在使用对象后将它们设置回Nothing。

编辑

对于每个工作簿，我会将Activesheet 替换为Sheets("SheetName")。否则，您可以将以下代码放入每个工作簿的工作簿对象中（并将它们全部保存为启用宏），除了 master，并保留Activesheet：

Private Sub Workbook_Open( )
     Sheets ("SheetName").Activate
 End Sub

我至少会将Workbooks("master").ActiveSheet 更改为Workbooks("master").Sheets("SheetName")，否则您需要记住从正确的（即活动的）工作表运行它。这也是一个很有帮助的link。

【讨论】：

嗨，布赖恩，这是个好建议——而且很有道理。如何使我的变量成为工作簿中的特定工作表 - 你能指出我正确的方向，然后我会试一试，告诉你我要去哪里。非常感谢
还有一件事，你考虑过使用公式吗？您可以使用公式从已关闭的工作簿中提取数据。
嗨，布赖恩，这太棒了！我会玩它，让你知道我是怎么过的。我没有尝试公平地使用公式 - 如果我只使用公式，我不确定数据将如何更新。也许我做了一个错误的假设。无论哪种方式，我都在学习 VBA，这不是一件坏事！再次感谢！丰富
@RichJoyce 随时！如果我的回答解决了您的问题或以任何方式提供帮助，您会标记为正确还是赞成（或两者兼而有之）？谢谢！
嗨 - 我们在这里度过了一个国庆节，所以我刚刚回到电脑前继续。当然我会标记你（如果它让我的声望分数低）我会尽快这样做。

【解决方案4】：

这将合并一个文件夹中所有工作簿的范围（下一个数据集在之前的下方）。

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

这将合并文件夹中所有工作簿的范围（下一个数据集位于前一个的右侧）。

Sub Basic_Example_3()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceCcount As Long, Fnum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim Cnum 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)
    Cnum = 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
                Set sourceRange = mybook.Worksheets(1).Range("A1:A10")

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    'if SourceRange use all rows then skip this file
                    If sourceRange.Rows.Count >= BaseWks.Rows.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then

                    SourceCcount = sourceRange.Columns.Count

                    If Cnum + SourceCcount >= BaseWks.Columns.Count Then
                        MsgBox "Sorry there are not enough columns in the sheet"
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else

                        'Copy the file name in the first row
                        With sourceRange
                            BaseWks.cells(1, Cnum). _
                                    Resize(, .Columns.Count).Value = MyFiles(Fnum)
                        End With

                        'Set the destrange
                        Set destrange = BaseWks.cells(2, Cnum)

                        '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

                        Cnum = Cnum + SourceCcount
                    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

【讨论】：