New Excel Forum

This forum has been moved to TeachExcel.com

Ask all future questions in the New Excel Forum.

ExcelKey

Loop through several workbooks

Free Excel Macros

Loop through several workbooks

Postby Sisyphus » Mon Sep 10, 2012 6:20 am

If you have a workbook from which you wish to extract data to another this code is for you. In fact, you can open any number of workbooks, one after the other, extract, modify or add data in them and close them again silently. All data extracted are written to the master workbook or, in fact, taken from the master and distributed to all others. This code just opens and closes the workbooks.
Code: Select all
Option Explicit

Public Sub LoopThruWorkbooks()

    ' Specify the folder where your files are located
      ' make sure FilePath ends with a path separator
    Const FilePath As String = "D:\My Documents\For Reference Only\ExcelKey\"
   
    ' enter each file name between quotation marks
      ' you can add as many as you like
      ' all names excepting the first must be preceded by a backslash
      ' and must include the extension
    Const FileNames As String = "120129 Club Inventory.xls" & _
                                 "\File 2.xlsx" & _
                                 "\File 3.xlsm" & _
                                 "\File 4.xlst"
   
    Dim Wb As Workbook
    Dim Ffn() As String
    Dim Fn As String
    Dim i As Integer
    Dim WasOpen As Boolean
   
    Application.ScreenUpdating = False

    Ffn = Split(FileNames, "\")
    For i = LBound(Ffn) To UBound(Ffn)
        Fn = FilePath & Trim(Ffn(i))
        If Len(Dir(Fn)) Then
            With Workbooks
                On Error Resume Next
                Set Wb = .Item(Ffn(i))
                WasOpen = Not CBool(Err)
                If Not WasOpen Then
                    Set Wb = .Open(Fn, ReadOnly:=True)
                End If
                On Error GoTo 0
            End With
           
            ' this message box is for demonstration only
              ' It may be deleted when no longer required
            MsgBox "File '" & Ffn(i) & "' is now open." & vbCr & _
                   "Data can be extracted using VBA" & vbCr & _
                   "before closing the book automatically."
                   
            ' Extract whatever data you want here
           
            If Not WasOpen Then Wb.Close SaveChanges:=False
        Else
            If MsgBox("The workbook '" & Ffn(i) & "' wasn't found." & vbCr & _
                      "Check the spelling of the file name, that" & vbCr & _
                      "the file exists in the specified directory," & vbCr & _
                      "and that it is of " & Extension(Ffn(i)) & " type.", _
                      vbOKCancel, "Specified workbook not found") = vbCancel Then
                Exit For
            End If
           
        End If
    Next i
   
    Application.ScreenUpdating = True
End Sub

Private Function Extension(ByRef Fn As String) As String

    Dim Sp() As String
   
    Sp = Split(Fn, ".")
    Extension = UCase(Sp(UBound(Sp)))
End Function
Paste to a standard code module, which should reside in the master workbook in applications I have imagined.

You must set the constants PathName and FileNames. Follow the instructions contained in the remarks.
Note that any workbook found already open will be processed as required by the code you add but will not be closed by the above code.
Have a great day! :D

Sisyphus
I do this for "honour and country" - much less of the latter, actually.
If I helped you, award points, plenty of them.
If I bored you, deduct points for being too long-winded. (I know, :lol)
Sisyphus
Former Moderator
 
Posts: 4454
Joined: Dec 7, 2011
Location: Shanghai
Reputation: 203
Excel Version: 2010

Return to Excel Macros

Who is online

Users browsing this forum: No registered users and 24 guests

cron