Excel VBA - Multiple Dir() in Same Folder

Question

I am working on this codes, but can't make it work.

Here is my working code:

Sub AREA21()


Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim regFile As String
Dim myExtension As String
Dim RegX As String

'Optimize Macro Speed
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    ThisWorkbook.UpdateLinks = xlUpdateLinksNever

myPath = "C:UsersAspire E 14Desktopxxxxx"

'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
  myExtension = "*area trees yield of NFICCs in *.xls*"
  RegX = "*area trees yield of NFICCs in REG*.xls*"

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)
  regFile = Dir(RegX & myExtension)

'Loop through each Excel file in folder
  Do While myFile <> ""
    'Set variable equal to opened workbook
    If myFile = regFile Then GoTo skipRegFile
    
      Set wb = Workbooks.Open(Filename:=myPath & myFile, UpdateLinks:=False)
    
    'Ensure Workbook has opened before moving on to next line of code
      DoEvents
    
    'my codes here
    For i = 1 To Sheets.Count
    
        Sheets(i).Select
  
    Next i
    

        
     'Save and Close Workbook
      wb.Close SaveChanges:=True
      
    'Ensure Workbook has closed before moving on to next line of code
      DoEvents
      
skipRegFile:
    'Get next file name
      myFile = Dir

  Loop

'Message Box when tasks are completed
  MsgBox "Task Complete!"

ResetSettings:
  'Reset Macro Optimization Settings
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    ThisWorkbook.UpdateLinks = xlUpdateLinksAlways



End Sub

Here is the sample folder:

Files with "REG**" are just the summary of respective provinces.

My goal is to run the codes in provincial files, and skip opening the file if it is a regional summary. However, problems occur when getting the next file in Dir statement as it appears blank.

Still looking for a better work around.

question from:https://stackoverflow.com/questions/65930663/excel-vba-multiple-dir-in-same-folder

Answer 1

You can adapt this code to suit your needs.

Some suggestions:

• Name your variables to something meaningful (sh is hard to understand, sourceRange it's easier)
• Indent your code properly (you can use Rubberduckvba.com) to help you with data
• Try to break your code into pieces (e.g. first validate, then prepare, then add items)
• Comment your code

Code:

Public Sub Area21()

    ' Basic error handling
    On Error GoTo CleanFail

    ' Turn off stuff
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    ThisWorkbook.UpdateLinks = xlUpdateLinksNever

    ' Define files path
    Dim filesPath As String
    filesPath = "C:TEMP"
    
    ' Define file name string to match
    Dim fileString As String
    fileString = "demo"
    
    ' Define file name
    Dim fileName As String
    fileName = Dir(filesPath, vbNormal)
    
    ' Loop through files
    Do While fileName <> ""
        'Set variable equal to opened workbook
        If InStr(LCase(fileName), LCase(fileString)) > 0 Then
        
            ' Set a reference to the workbook
            Dim targetWorkbook As Workbook
            Set targetWorkbook = Workbooks.Open(fileName:=filesPath & fileName, UpdateLinks:=False)
            
            'Ensure Workbook has opened before moving on to next line of code
            DoEvents
            
            ' DO SOMETHING WITH THE WORKBOOK
            
            'Save and Close Workbook
            targetWorkbook.Close SaveChanges:=True
            
            'Ensure Workbook has closed before moving on to next line of code
            DoEvents
            
        End If
        
        fileName = Dir()
    Loop

CleanExit:
    ' Turn on stuff
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    ThisWorkbook.UpdateLinks = xlUpdateLinksAlways
    Exit Sub
    
CleanFail:
    MsgBox "Error " & Err.Description
    GoTo CleanExit
End Sub