Loop Through Folder and Take Specific Actions Based on Filename

reberryjr

Well-known Member
Joined
Mar 16, 2017
Messages
714
Office Version
  1. 365
Platform
  1. Windows
I've looked around the web a bit, but I'm struggling to find a solution that fits my needs. Essentially, I want to be able to push a button and have VBA tap out to a specific folder and loop through each excel file within that folder and take certain actions based on the filename. There could be different versions of a file (e.g., Apple1, Apple2, Apple7, etc.). If I'm reaching out for a particular file, I can code to that, but getting the code to read the filename so it knows what actions to take is throwing me off. Here's what I have so far:
VBA Code:
Sub ImportDataFiles()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim m As Workbook
Dim mI As Worksheet, mV As Worksheet, mN As Worksheet, mO As Worksheet, mP As Worksheet
Dim mILR As Long, mVLR As Long, mNLR As Long, mOLR As Long, mPLR As Long
Dim fP As String, fF As String, fE As String

Set m = ThisWorkbook
Set mI = m.Sheets("CC_I")
Set mV = m.Sheets("CC_V")
Set mN = m.Sheets("CC_N")
Set mO = m.Sheets("OP")
Set mP = m.Sheets("P")

'Sets the Tool's input folder location.
fP = ("\\Network Shared Drive\") 'Actual path removed for security reasons.

'Declares the target files' extension as Excel.
fE = "*.xls*"

fF = Dir(fP & fE)

'Loop through the Tool's input folder and import data files.
Do While fF <> ""

    If fF = "Apple.xls*" Then
        mI.Range("A4") = "Red"
    Else
        If fF = "Banana.xls*" Then
            mI.Range("A7") = "Yellow"
        End If
    End If

Loop

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
 
So in the code above that we worked on, you wanted to find specific files based on the name. The ImportCCIQRData doesn't use the name found, it uses it's own (*Quality Report.xlsx)

The changes I made below will send the path & filename to the Import SUB for each one it finds. Call it from the ImportDataFiles SUB like this: ImportCCIQRData(FP & FF)


VBA Code:
Sub ImportCCIQRData(PathFile As String)

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim m As Workbook, s As Workbook
Dim mI As Worksheet, sD As Worksheet
Dim mILR As Long, sDLR As Long

Set m = ThisWorkbook
Set mI = m.Sheets("CC_I")

'Removes filters from the working data if any exist.
If mI.AutoFilterMode Then mI.AutoFilterMode = False

'Unhides any columns and rows that may be hidden on the working data.
With mI.UsedRange
    .Columns.EntireColumn.Hidden = False
    .Rows.EntireRow.Hidden = False
End With

mILR = mI.Range("A" & Rows.Count).End(xlUp).Row

'*****This section allows the User to select individual files for upload.*****
'Prompts the User to select the desired file to import.
'ISelect = MsgBox("Navigate to, and open the most recent Quality report.", vbOKCancel + vbInformation)

'If ISelect = vbOK Then
'    With Application.FileDialog(3)
'        .AllowMultiSelect = False
'        If .Show Then
'            fullpath = .SelectedItems.Item(1)
'            Set s = Workbooks.Open(fullpath)
'        End If
'
'        If s Is Nothing Then Exit Sub
'
'        Set sD = s.Sheets("Risk Responses")
'
'        sDLR = sD.Range("A" & Rows.Count).End(xlUp).Row
'    End With
'Else:  Exit Sub
'End If

'Opens and sets the source file.
Set s = Workbooks.Open(PathFile)
Set sD = s.Sheets("Risk Responses")
sDLR = sD.Range("A" & Rows.Count).End(xlUp).Row

sD.Activate

'Deletes the first 3 rows as they don't contain pertinent data.
sD.Range("A1:A3").EntireRow.Delete

'Removes filters from the source data if any exist.
If sD.AutoFilterMode Then sD.AutoFilterMode = False

'Unhides any columns and rows that may be hidden on the source data.
With sD.UsedRange
    .Columns.EntireColumn.Hidden = False
    .Rows.EntireRow.Hidden = False
End With

'Copies the data from the source file and pastes it onto this worksheet.
sD.Range("A2:P" & sDLR).Copy
    mI.Range("A" & mILR + 1).PasteSpecial xlPasteValues

'Closed the source file without saving it.
s.Close SaveChanges:=False

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
 
Upvote 0

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
So in the code above that we worked on, you wanted to find specific files based on the name. The ImportCCIQRData doesn't use the name found, it uses it's own (*Quality Report.xlsx)

The changes I made below will send the path & filename to the Import SUB for each one it finds. Call it from the ImportDataFiles SUB like this: ImportCCIQRData(FP & FF)


VBA Code:
Sub ImportCCIQRData(PathFile As String)

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim m As Workbook, s As Workbook
Dim mI As Worksheet, sD As Worksheet
Dim mILR As Long, sDLR As Long

Set m = ThisWorkbook
Set mI = m.Sheets("CC_I")

'Removes filters from the working data if any exist.
If mI.AutoFilterMode Then mI.AutoFilterMode = False

'Unhides any columns and rows that may be hidden on the working data.
With mI.UsedRange
    .Columns.EntireColumn.Hidden = False
    .Rows.EntireRow.Hidden = False
End With

mILR = mI.Range("A" & Rows.Count).End(xlUp).Row

'*****This section allows the User to select individual files for upload.*****
'Prompts the User to select the desired file to import.
'ISelect = MsgBox("Navigate to, and open the most recent Quality report.", vbOKCancel + vbInformation)

'If ISelect = vbOK Then
'    With Application.FileDialog(3)
'        .AllowMultiSelect = False
'        If .Show Then
'            fullpath = .SelectedItems.Item(1)
'            Set s = Workbooks.Open(fullpath)
'        End If
'
'        If s Is Nothing Then Exit Sub
'
'        Set sD = s.Sheets("Risk Responses")
'
'        sDLR = sD.Range("A" & Rows.Count).End(xlUp).Row
'    End With
'Else:  Exit Sub
'End If

'Opens and sets the source file.
Set s = Workbooks.Open(PathFile)
Set sD = s.Sheets("Risk Responses")
sDLR = sD.Range("A" & Rows.Count).End(xlUp).Row

sD.Activate

'Deletes the first 3 rows as they don't contain pertinent data.
sD.Range("A1:A3").EntireRow.Delete

'Removes filters from the source data if any exist.
If sD.AutoFilterMode Then sD.AutoFilterMode = False

'Unhides any columns and rows that may be hidden on the source data.
With sD.UsedRange
    .Columns.EntireColumn.Hidden = False
    .Rows.EntireRow.Hidden = False
End With

'Copies the data from the source file and pastes it onto this worksheet.
sD.Range("A2:P" & sDLR).Copy
    mI.Range("A" & mILR + 1).PasteSpecial xlPasteValues

'Closed the source file without saving it.
s.Close SaveChanges:=False

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
@Jeffrey Mahoney I haven't forgotten about this. I had to implement a workaround, but once I get past another part of this project, I'll circle back to this as I want to understand how it should work. I appreciate all of your feedback!
 
Upvote 0

Forum statistics

Threads
1,223,894
Messages
6,175,254
Members
452,623
Latest member
Techenthusiast

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