異なるExcelワークブックのデータをマージする

Question

まず、コーディングについては初心者ですが、データを掘り下げるのに役立つかどうかを確認しています。

私は現在、異なるチームメンバーのタイムシートデータをキャプチャし、それをマスターの要約ブックにコピーすることを検討しています。

マクロを記録してから、コードをきれいにするために少し再構成しました（これは私が間違っていた場所です）。しかし、今私は私のマクロを実行すると、実行時エラー '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の後に、各ラインに登場されたいくつかのコードを取り出した行をアクティブにします。。これはだった：

私はこれは私が正しい場所までスクロールし、これに依存して、それぞれの時間を保存する前に、アクティブセルだったときだけだったと信じていたよう

ActiveWindow.SmallScroll Down:=-18 

、これは変化するであろう。

私は考えが尽きていて、どんな助けでも大歓迎です。

私はこれまで、チューブチュートリアルのビデオに続いて、サイトからコードをコピーして貼り付けるなど、いくつかの異なる方法を試しましたが、それぞれの方法と同じ方法で同じエラーが発生します。事前に

おかげで、

リッチ

UPDATE

私はマクロを再記録し、単に私がレコード中に何をしたかの順序を変更し

。私はもはやエラーを取得しません。しかし、コードは非常に乱雑で、長引く。プロセス中に画面が大きくちらつきます。それはユーザーのためのよりスムーズな体験にする方法はありますか？新しいコードでは、これまでの援助のためのUPDATE

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

多くのおかげです。私はそれを書くために「マスター」内のどのシートもからそれをコピーするには、「2016_JAMAL」内のどのシート選択できるように

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

：私は、この行を編集していますよ。

第2に、このシートの2つの範囲からコピーしたいと思います.C2：G2とC5：G56 これを合理的な方法で実行したいと思います。

これまでのお返事に感謝します。私はアレイに関する情報を読み、5ページで作業します！

リッチ

Answer 1

次を設定することにより、ちらつき画面を停止することができます：

Application.ScreenUpdating = False 

はマクロにそれを追加し、再度実行します。

Answer 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 

あなたはまた、あなたの「近い」部分を簡単にすることができ

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 

Answer 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 

それはあなたの変数を宣言するために、それらを使用した後に戻ってNothingにあなたのオブジェクトを設定することができ強制的Option Explicitを使用することをお勧めします。

EDIT

私はワークブックのそれぞれについて、Sheets("SheetName")でActivesheetを置き換えます。そうしないとあなたがすべてのワークブックのワークブックオブジェクトに次のコードを入れて（とマクロが有効になってそれらをすべて保存）、マスターを除く、とActivesheetを保つことができる：

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

私は、少なくとも、Workbooks("master").Sheets("SheetName")にWorkbooks("master").ActiveSheetを変更したり、あなたでしょう正しい（つまりアクティブな）シートから実行することを忘れないでください。これは非常に有用なlinkです。

Answer 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