How can I amend my code do that it loops through all workbooks in a folder?

I have amended some code supplied by another EE expert for a different job.
I have put Excel files in a folder named "Source"
I would like to copy data from Source files to a master file, then save the new file with the same file name as the source file.
I would like to output the new files to another folder.
I want to run the code from a neutral workbook that is unaffected by the changes.

The code copies a small amount of data for test purposes only.
However the attached code accesses one source file only, creates a new file, then finishes.

Please advise where the code is incorrect.

Thanks

Sub TransferDataToMasterWB()

    Dim MyDir As String, strPath As String, WSheet As String, NewFoldDir As String, MastWB As String, MastWBDir As String, SourceWBDir As String, FileType As String
    Dim ModNo As String, vaFileName As Variant, I As Integer
    Dim VBProj As VBIDE.VBProject
    Dim VBComp As VBIDE.VBComponent
    Dim FName As String

    MyDir = ActiveWorkbook.Path & "\" & Range("B10").Value   ' current path
    FName = Dir(MyDir & "\" & "*.xl??")
    WSheet = Range("B9").Value
    ModNo = Range("B11").Value
    MastWB = Range("B15").Value
    FileType = "." & Range("C15").Value
    
    MastWBDir = ActiveWorkbook.Path & "\" & MastWB & FileType
    SourceWBDir = MyDir & "\" & FName
    NewFoldDir = ActiveWorkbook.Path & "\" & Range("B16").Value
    
    If Len(Dir(NewFoldDir, vbDirectory)) = 0 Then
    MkDir NewFoldDir
    End If

    Do Until FName = ""

        ' open the source workbook
        Workbooks.Open MastWBDir
        Workbooks.Open MyDir & "\" & FName
       
        With Workbooks(MastWB & FileType)
        Workbooks(MastWB & FileType).Worksheets("Quote").Range("G4").Value = Workbooks(FName).Worksheets("Quote").Range("G4").Value
        
        
        Workbooks(FName).Save
        Workbooks(FName).Close savechanges:=False
        
            .SaveAs FileName:=NewFoldDir & "\" & FName
            .Close
        End With
        
   FName = Dir
    Loop

End Sub

Open in new window

spar-kleOperations DirectorAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Roy CoxGroup Finance ManagerCommented:
Here's some code that I use regularly. You should be able to adapt it to your requirements

Option Explicit


'---------------------------------------------------------------------------------------
' Module    : Data
' Author    : Roy Cox (royUK)
' Website   : for more examples and Excel Consulting
' Date      : 19/11/2011
' Purpose   : Combine data from several workbooks
' Disclaimer: Disclaimer; This code is offered as is with no guarantees. You may use it in your
'             projects but please leave this header intact.
 
'---------------------------------------------------------------------------------------



Sub CombineData()
    Dim oWbk As Workbook
    Dim rRng As Range
    Dim rToCopy As Range
    Dim rNextCl As Range
    Dim lCount As Long
    Dim bHeaders As Boolean
    Dim sFil As String
    Dim sPath As String

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        '   On Error GoTo exithandler
        ' assumes workbooks are in a sub folder named "Data"
        sPath = ThisWorkbook.Path & Application.PathSeparator & "Data"
        ChDir sPath
        sFil = Dir("*.xl**")    'file type
        Do While sFil <> ""    'will start LOOP until all files in folder sPath have been looped through

            With ThisWorkbook.Worksheets(1)
                Set rRng = .Range("A1").CurrentRegion
                If rRng.Cells.Count = 0 Then
                    'no data in master sheet
                    bHeaders = False
                Else: bHeaders = True
                End If

                Set oWbk = Workbooks.Open(sPath & Application.PathSeparator & sFil)    'opens the file
                'A1 must be within the data, if not amend the Range below
                Set rToCopy = oWbk.ActiveSheet.Range("A1").CurrentRegion
                If Not bHeaders Then
                    Set rNextCl = .Cells(1, 1)
                    bHeaders = True
                Else: Set rNextCl = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
                    'headers exist so don't copy
                    Set rToCopy = rToCopy.Offset(1, 0).Resize(rToCopy.Rows.Count - 1, _
                                                              rToCopy.Columns.Count)
                End If
                rToCopy.Copy rNextCl
            End With
            oWbk.Close False     'close source workbook
            sFil = Dir
        Loop    ' End of LOOP
        'sort to remove empty rows
        Set rRng = ThisWorkbook.Worksheets(1).UsedRange
        rRng.Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
                  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                  DataOption1:=xlSortNormal
exithandler:
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
End Sub

Open in new window

Saurabh Singh TeotiaCommented:
Sparkle,

I don't see any problem in your code..and it should get data from multiple files...Can you ensure in this path..

FName = Dir(MyDir & "\" & "*.xl??")

Open in new window


You have more then one file present..??

or can you try changing this line...

FName = Dir

to this..

FName = Dir()

Saurabh...
Saurabh...
spar-kleOperations DirectorAuthor Commented:
Thanks Saurabh
Yes there are 7 files in folder for testing

I have changed line as suggested without success.

Only the first file in the "Source" folder is opened and and saved with changes in the Amended Files folder
Build an E-Commerce Site with Angular 5

Learn how to build an E-Commerce site with Angular 5, a JavaScript framework used by developers to build web, desktop, and mobile applications.

spar-kleOperations DirectorAuthor Commented:
Thanks Roy.

However, I'm not trying to copy data from multiple workbooks into one workbook.
I'm trying to copy data from one "source" workbook at a time to a "target" workbook that has more macros and associated buttons. Save the updated target workbook to a specified location with the same as the source workbook then close both workbooks, open the next source workbook, copy data to the target workbook, save the updated target workbook to the specified location, close workbooks then open the next source workbook.... etc
spar-kleOperations DirectorAuthor Commented:
Any ideas please?
Roy CoxGroup Finance ManagerCommented:
Are you  trying to copy data from each source file to individual new workbooks,i.e. combine pages in each source file>
spar-kleOperations DirectorAuthor Commented:
Thanks Roy
Yes.
Basically I've updated a template from which workbooks are created.
Although its for a different job, think of an invoice with various macros to automate parts of the process.
The template has been updated with new macros and macro buttons.
I want to update all of the old workbooks so that we can utilise the new macros with new buttons when we open them.
Thanks
Des
Roy CoxGroup Finance ManagerCommented:
I'll have a look when I get home. It would help if you could attach an example of the workbooks
spar-kleOperations DirectorAuthor Commented:
Samples attached as requested ...thanks
Samples.zip
Saurabh Singh TeotiaCommented:
Spar-kle,

Like i said i didn't found any problem in the code your code was perfect..It was just sequence of events which was messy in your code as i notice you are using the dir command again which is kind of resetting the dir which you are using so if i change only the sequence of events and then run the code it does what you are looking for..

In additional i added couple of more things in your code to make it more effective and not to run the workbook open macro when i run this from your code..

Enclosed is the revised code for your reference..

Sub TransferDataToMasterWB()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False



    Dim MyDir As String, strPath As String, WSheet As String, NewFoldDir As String, MastWB As String, MastWBDir As String, SourceWBDir As String, FileType As String
    Dim ModNo As String, vaFileName As Variant, I As Integer
    Dim VBProj As VBIDE.VBProject
    Dim VBComp As VBIDE.VBComponent
    Dim FName As String

    
        WSheet = Range("B9").Value
    ModNo = Range("B11").Value
    MastWB = Range("B15").Value
    FileType = "." & Range("C15").Value

    MastWBDir = ActiveWorkbook.Path & "\" & MastWB & FileType
    SourceWBDir = MyDir & "\" & FName
    NewFoldDir = ActiveWorkbook.Path & "\" & Range("B16").Value

    If Len(Dir(NewFoldDir, vbDirectory)) = 0 Then
    MkDir NewFoldDir
    End If
    

    MyDir = ActiveWorkbook.Path & "\" & Range("B10").Value    ' current path
    FName = Dir(MyDir & "\" & "*.xl??")


    Do Until FName = ""

        ' open the source workbook
        Workbooks.Open MyDir & "\" & FName
        Workbooks.Open MastWBDir
        
       
        With Workbooks(MastWB & FileType)
        Workbooks(MastWB & FileType).Worksheets("Quote").Unprotect

        Workbooks(MastWB & FileType).Worksheets("Quote").Range("G3").Value = Workbooks(FName).Worksheets("Quote").Range("G3").Value
        Workbooks(MastWB & FileType).Worksheets("Quote").Range("G4").Value = Workbooks(FName).Worksheets("Quote").Range("G4").Value
        Workbooks(MastWB & FileType).Worksheets("Quote").Range("I4").Value = Workbooks(FName).Worksheets("Quote").Range("I4").Value
        Workbooks(MastWB & FileType).Worksheets("Quote").Range("M5:M8").Value = Workbooks(FName).Worksheets("Quote").Range("M5:M8").Value
        Workbooks(MastWB & FileType).Worksheets("Quote").Range("M13:M14").Value = Workbooks(FName).Worksheets("Quote").Range("M13:M14").Value
        Workbooks(MastWB & FileType).Worksheets("Quote").Range("M15").Value = Workbooks(FName).Worksheets("Quote").Range("M19").Value
        Workbooks(MastWB & FileType).Worksheets("Quote").Range("D6:D9").Value = Workbooks(FName).Worksheets("Quote").Range("D6:D9").Value
        Workbooks(MastWB & FileType).Worksheets("Quote").Range("D14:D15").Value = Workbooks(FName).Worksheets("Quote").Range("D14:D15").Value

        Workbooks(MastWB & FileType).Worksheets("Quote").Range("B18:B35").Value = Workbooks(FName).Worksheets("Quote").Range("B18:B35").Value
        Workbooks(MastWB & FileType).Worksheets("Quote").Range("C18:C35").Value = Workbooks(FName).Worksheets("Quote").Range("C18:C35").Value
        Workbooks(MastWB & FileType).Worksheets("Quote").Range("D18:D35").Value = Workbooks(FName).Worksheets("Quote").Range("D18:D35").Value
        Workbooks(MastWB & FileType).Worksheets("Quote").Range("F18:F35").Value = Workbooks(FName).Worksheets("Quote").Range("F18:F35").Value
        Workbooks(MastWB & FileType).Worksheets("Quote").Range("G18:G35").Value = Workbooks(FName).Worksheets("Quote").Range("G18:G35").Value
        Workbooks(MastWB & FileType).Worksheets("Quote").Range("I18:I35").Value = Workbooks(FName).Worksheets("Quote").Range("I18:I35").Value
        Workbooks(MastWB & FileType).Worksheets("Quote").Range("H36").Value = Workbooks(FName).Worksheets("Quote").Range("H36").Value

        Workbooks(MastWB & FileType).Worksheets("Quote").Range("B56:B77").Value = Workbooks(FName).Worksheets("Quote").Range("B56:B77").Value
        Workbooks(MastWB & FileType).Worksheets("Quote").Range("C56:C77").Value = Workbooks(FName).Worksheets("Quote").Range("C56:C77").Value
        Workbooks(MastWB & FileType).Worksheets("Quote").Range("D56:D77").Value = Workbooks(FName).Worksheets("Quote").Range("D56:D77").Value
        Workbooks(MastWB & FileType).Worksheets("Quote").Range("F56:F77").Value = Workbooks(FName).Worksheets("Quote").Range("F56:F77").Value
        Workbooks(MastWB & FileType).Worksheets("Quote").Range("G56:G77").Value = Workbooks(FName).Worksheets("Quote").Range("G56:G77").Value
        Workbooks(MastWB & FileType).Worksheets("Quote").Range("I56:I77").Value = Workbooks(FName).Worksheets("Quote").Range("I56:I77").Value
        Workbooks(MastWB & FileType).Worksheets("Quote").Range("H78").Value = Workbooks(FName).Worksheets("Quote").Range("H78").Value

        Workbooks(MastWB & FileType).Worksheets("Quote").Protect

        Workbooks(FName).Save
        Workbooks(FName).Close savechanges:=False

            .SaveAs FileName:=NewFoldDir & "\" & FName
            .Close
        End With
        
   FName = Dir()
    Loop

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub

Open in new window


Saurabh...

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
spar-kleOperations DirectorAuthor Commented:
Thanks Saurabh
Really appreciate your help yet again!
I didn't realise that the positioning of the Dir command line was so critical....
Des
Saurabh Singh TeotiaCommented:
Des,

Yeah.. The because if you use the dir command again that resets your directory to the new one so thats why..Again always happy to help.. :-)

Saurabh...
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.