Vba to cycle through sub folders and perform functions on excel files

dshafique

Board Regular
Joined
Jun 19, 2017
Messages
171
hi everyone, I have a folder with subfolders that have excel files in them. I am trying to have a vba loop go through each of the sub folders, extract the value from Cell F1 from a specific sheet and then paste that value into another workbook. a couple of roadblocks:
1.) each folder has a specific name
2.) i only want it to open files that end with a specific name (like if im donig a july report, only open reports ending in "july" i.e. 'john Smith July report"0
3.) the number of folders keeps changing, it either lessens or adds, so I want to do something dynamic.

here is what I have so far:

Code:
Sub loopAllSubFolderSelectStartDirector()

'Another Macro must call LoopAllSubFolders Macro to start to procedure
Call LoopAllSubFolders("C:\Users\dshafiq\Desktop\MS Zia\")


End Sub


'List all files in sub folders
Sub LoopAllSubFolders(ByVal folderPath As String)


Dim fileName As String
Dim fullFilePath As String
Dim numFolders As Long
Dim folders() As String
Dim i As Long


If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
fileName = Dir(folderPath & "*.*", vbDirectory)


While Len(fileName) <> 0


    If Left(fileName, 1) <> "." Then
 
        fullFilePath = folderPath & fileName
 
        If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
            ReDim Preserve folders(0 To numFolders) As String
            folders(numFolders) = fullFilePath
            numFolders = numFolders + 1
        Else
            'Insert the actions to be performed on each file
            'This example will print the full file path to the immediate window
        Workbooks.Open (fileName)
        Set Rng = Worksheets("Week 1").Cells("F1")
        Windows("Temp.xlsx").Activate
        Cells(1, 1).Select
        Rng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Application.CutCopyMode = False
               ' Debug.Print folderPath & fileName
        End If
 
    End If
 
    fileName = Dir()


Wend


For i = 0 To numFolders - 1


    LoopAllSubFolders folders(i)
 
Next i


End Sub

I run into a weird error telling me that my file could not be found, check the spelling etc. in my case it says the file 'John smith July.xlsx' could not be found. it clearly exists cause it pulled the name.
i am at my wit's end here, i would really appreciate some help

thanks
 

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.
What happens if you change the code to:
Code:
[COLOR=#333333]Workbooks.Open ([/COLOR][COLOR=#333333]fullFilePath[/COLOR][COLOR=#333333])[/COLOR]
 
Upvote 0
thanks @shknbk2, that was the answer i needed. the other issue that came up after that is looping. i wanted to have it paste the value from each workbook into a cell in the new workbook. like example, paste into Cell(1,1) then Cell(2,1) etc. this is what I had so far, but it only pastes the value of 2 sheets.

Code:
Sub loopAllSubFolderSelectStartDirector()'Another Macro must call LoopAllSubFolders Macro to start to procedure


Workbooks.Open ("C:\Users\dshafiq\Desktop\Temp.xlsx")
Call LoopAllSubFolders("C:\Users\dshafiq\Desktop\MS Zia\")




End Sub




'List all files in sub folders
Sub LoopAllSubFolders(ByVal folderPath As String)




Dim fileName As String
Dim fullFilePath As String
Dim numFolders As Long
Dim folders() As String
Dim i As Long
Dim Temp As String
Dim k As Long




k = 1
Temp = "C:\Users\dshafiq\Desktop\Temp.xlsx"
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
fileName = Dir(folderPath & "*.*", vbDirectory)




While Len(fileName) <> 0




    If Left(fileName, 1) <> "." Then
 
        fullFilePath = folderPath & fileName
 
        If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
            ReDim Preserve folders(0 To numFolders) As String
            folders(numFolders) = fullFilePath
            numFolders = numFolders + 1
        Else
            'Insert the actions to be performed on each file
            'This example will print the full file path to the immediate window
        Workbooks.Open (fullFilePath)
        Set Rng = Worksheets("Week 1").Range("F1")
       ' Sheets("Week 1").Activate
       ' Range("F1").Select
      '  Selection.Copy
        Workbooks("Temp.xlsx").Activate
        
        Cells(k, 1).Value = Rng.Cells.Value
        
       ' Selection.PasteSpecial Paste:=xlPasteValues
    
        'Selection.Paste
        
     '   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    '        :=False, Transpose:=False
        Application.CutCopyMode = False
               ' Debug.Print folderPath & fileName
        End If
  k = k + 1


    End If
 
    fileName = Dir()




Wend




For i = 0 To numFolders - 1




    LoopAllSubFolders folders(i)
    
        
Next i




End Sub

thanks
 
Upvote 0
Move the "k = k + 1" up one line above the End If (or if you want to right below the Cells(k, 1).Value line). Where it is currently, k will always increase even if you have found a directory.

Does that change the results you need?
 
Upvote 0
thanks for the response, unfortunately it still only pastes 2 values, when in reality there should be 6 (I'm trying this out with 6 files)
 
Upvote 0
Do you know how to step through the code (F8)? What is the value of Rng.Cells.Value when you get there for the other 4 files?
 
Upvote 0

Forum statistics

Threads
1,223,227
Messages
6,170,849
Members
452,361
Latest member
d3ad3y3

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top