Member Avatar for Divinedar

I am trying to do the following in excel 2010:

For instance:

If I have a directory file name "Brazilian Navy Ku" and then I have another directory file folder name " Brazilian Aeronautical VSAT Spares"; then it will go through the first directory file folder name, search for excel files, open the excel file, search for any worksheet tab with tab format XX.XXX or tab format XX.XXX.XX, then retrieve information from certain cells within that excel file.

I just need to be able to have it search within a folder by a certain name criteria of the folder name. I only need to search file folders that meet the criteria specified within the criteria box.

  • 1 Contributor
  • 1 Reply
  • 262 Views
  • 2 Days Discussion Span
  • Latest Post Latest Post by Divinedar

Dani AI

Generated

As described, the goal is to prompt for a folder-name criterion, then open only folders that match that criterion and extract values from worksheets whose names follow the formats ##.### or ##.###.##. The snippet below implements that: it prompts for a root path, a folder-name substring (case-insensitive), and a comma-separated list of cell addresses (for example A1,B2). Matching folders (and any child folders under them) are scanned for Excel files; each workbook is opened read-only with macros disabled, matching sheets are read, and the requested cell values are written to a Summary sheet in the macro workbook.

Key points:

  • Late-binding Scripting.FileSystemObject is used so no VBA references need to be set.
  • Sheet-name matching uses Like "##.###" or Like "##.###.##"; a RegExp alternative is noted below for more complex rules.
  • Workbooks are opened with ReadOnly:=True and UpdateLinks:=0 and closed without saving.

Troubleshooting / cautions:

  • Scanning many folders/files can be slow; test on a small subtree first.
  • Password-protected or corrupted workbooks are skipped and recorded as errors in Summary.
  • The macro disables screen updating and forces macros off while opening files; automation-security is restored at the end.
  • Save the macro in a macro-enabled workbook (.xlsm) before running.

A ready-to-use VBA implementation follows. Place it in a standard module and run SearchFoldersByName.

Option Explicit

Sub SearchFoldersByName()
    Dim rootFolderPath As String, criteria As String, cellAddrs As String
    Dim cellList() As String, fso As Object, rootFolder As Object
    Dim summaryWS As Worksheet, outputRow As Long, oldAutoSec As Long, i As Long

    On Error Resume Next
    oldAutoSec = Application.AutomationSecurity
    On Error GoTo 0
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Application.AutomationSecurity = 3

    rootFolderPath = InputBox("Enter root folder path:", "Root folder", ThisWorkbook.Path)
    If Len(Trim(rootFolderPath)) = 0 Then GoTo Restore
    criteria = InputBox("Enter folder name criteria (substring, case-insensitive):", "Folder criteria")
    If Len(Trim(criteria)) = 0 Then GoTo Restore
    cellAddrs = InputBox("Enter comma-separated cell addresses to collect (e.g. A1,B2):", "Cells", "A1")
    If Len(Trim(cellAddrs)) = 0 Then GoTo Restore
    cellList = Split(Replace(cellAddrs, " ", ""), ",")

    On Error Resume Next
    Set summaryWS = ThisWorkbook.Worksheets("Summary")
    If summaryWS Is Nothing Then
        Set summaryWS = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        summaryWS.Name = "Summary"
    Else
        summaryWS.Cells.Clear
    End If
    On Error GoTo 0

    outputRow = 1
    summaryWS.Cells(outputRow, 1).Value = "FilePath"
    summaryWS.Cells(outputRow, 2).Value = "Workbook"
    summaryWS.Cells(outputRow, 3).Value = "Sheet"
    For i = LBound(cellList) To UBound(cellList)
        summaryWS.Cells(outputRow, 4 + i).Value = cellList(i)
    Next i
    outputRow = outputRow + 1

    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(rootFolderPath) Then
        summaryWS.Cells(outputRow, 1).Value = "Root folder not found: " & rootFolderPath
        GoTo Restore
    End If
    Set rootFolder = fso.GetFolder(rootFolderPath)
    ProcessFolder rootFolder, criteria, fso, summaryWS, outputRow, cellList

Restore:
    Application.AutomationSecurity = oldAutoSec
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Sub ProcessFolder(folder As Object, criteria As String, fso As Object, summaryWS As Worksheet, ByRef outputRow As Long, cellList As Variant)
    Dim subfolder As Object
    If InStr(1, folder.Name, criteria, vbTextCompare) > 0 Then
        ProcessFolderFiles folder, summaryWS, outputRow, cellList
    Else
        For Each subfolder In folder.SubFolders
            ProcessFolder subfolder, criteria, fso, summaryWS, outputRow, cellList
        Next subfolder
    End If
End Sub

Sub ProcessFolderFiles(folder As Object, summaryWS As Worksheet, ByRef outputRow As Long, cellList As Variant)
    Dim f As Object, wb As Workbook, sht As Worksheet
    For Each f In folder.Files
        If LCase(f.Name) Like "*.xls*" Then
            On Error Resume Next
            Set wb = Workbooks.Open(Filename:=f.Path, ReadOnly:=True, UpdateLinks:=0)
            If Err.Number <> 0 Then
                summaryWS.Cells(outputRow, 1).Value = "Error opening: " & f.Path
                summaryWS.Cells(outputRow, 2).Value = Err.Description
                outputRow = outputRow + 1
                Err.Clear
                GoTo NextFile
            End If
            On Error GoTo 0
            For Each sht In wb.Worksheets
                Dim sName As String: sName = Trim(sht.Name)
                If sName Like "##.###" Or sName Like "##.###.##" Then
                    Dim j As Long
                    summaryWS.Cells(outputRow, 1).Value = f.Path
                    summaryWS.Cells(outputRow, 2).Value = wb.Name
                    summaryWS.Cells(outputRow, 3).Value = sName
                    For j = LBound(cellList) To UBound(cellList)
                        On Error Resume Next
                        summaryWS.Cells(outputRow, 4 + j).Value = sht.Range(cellList(j)).Value
                        On Error GoTo 0
                    Next j
                    outputRow = outputRow + 1
                End If
            Next sht
            wb.Close SaveChanges:=False
            Set wb = Nothing
        End If
NextFile:
    Next f
    Dim sf As Object
    For Each sf In folder.SubFolders
        ProcessFolderFiles sf, summaryWS, outputRow, cellList
    Next sf
End Sub

Note: for a stricter sheet-name rule, replace the Like checks with a late-bound RegExp using the pattern ^\d{2}\.\d{3}(\.\d{2})?$.

Member Avatar for Divinedar

any help anybody?

Be a part of the DaniWeb community

We're a friendly, industry-focused community of developers, IT pros, digital marketers, and technology enthusiasts meeting, networking, learning, and sharing knowledge.