求VBA脚本：多目录匹配Log Number并填充Document Tracker列

Here's a VBA script that meets your requirements, with exact Log Number matching and directory traversal:

Sub PopulateDocumentTracker()
    Dim ws As Worksheet
    Dim regex As Object
    Dim targetDirs As Variant
    Dim logNum As String
    Dim currentDir As String
    Dim fileName As String
    Dim lastRow As Long
    Dim i As Long, j As Long
    Dim folderName As String
    
    ' Set the worksheet (change "Sheet1" to your actual sheet name)
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' Initialize regex for exact word match
    Set regex = CreateObject("VBScript.RegExp")
    regex.Global = False
    regex.IgnoreCase = True ' Case-insensitive match (adjust if needed)
    
    ' List of directories to search (add/remove paths as needed)
    targetDirs = Array( _
        "C:\Documents\Files\NBI", _
        "C:\Documents\Files\Authorized", _
        "C:\Documents\Files\Awaiting Check", _
        "C:\Documents\Processed\Rejected" _
    )
    
    ' Get last row with data in Log Number column (column A)
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' Loop through each row starting from row 2 (header is row 1)
    For i = 2 To lastRow
        logNum = Trim(ws.Cells(i, "A").Value)
        If logNum <> "" Then
            ' Set regex pattern to match exact Log Number as a standalone word
            regex.Pattern = "\b" & logNum & "\b"
            
            ' Search each target directory
            For j = LBound(targetDirs) To UBound(targetDirs)
                currentDir = targetDirs(j)
                ' Check if directory exists
                If Dir(currentDir, vbDirectory) <> "" Then
                    fileName = Dir(currentDir & "\*.*") ' Get all files in directory
                    Do While fileName <> ""
                        ' Check if filename contains exact Log Number
                        If regex.Test(fileName) Then
                            ' Extract folder name from directory path
                            folderName = Split(currentDir, "\")(UBound(Split(currentDir, "\")))
                            ' Populate Document Tracker column (column B)
                            ws.Cells(i, "B").Value = folderName
                            ' Exit loops once match is found
                            Exit Do
                        End If
                        fileName = Dir ' Next file
                    Loop
                    ' Exit directory loop if match found
                    If ws.Cells(i, "B").Value <> "" Then Exit For
                End If
            Next j
        End If
    Next i
    
    ' Cleanup
    Set regex = Nothing
    Set ws = Nothing
    MsgBox "Document Tracker populated successfully!", vbInformation
End Sub

Key Details: #

• Exact Match Prevention: The regex pattern \b ensures the Log Number is treated as a standalone word. For example, "1" won't match "1001" because there's no word boundary between "1" and "001".
• Directory Configuration: Modify the targetDirs array to include all directories you need to search. Ensure paths are correctly formatted with backslashes.
• Worksheet Setup: The script assumes Log Numbers are in column A and Document Tracker in column B, with headers in row 1. Adjust the sheet name and column references if your setup differs.
• Case Insensitivity: The regex is set to ignore case—if you need case-sensitive matching, change regex.IgnoreCase = True to False.
• Directory Existence Check: The script skips directories that don't exist to avoid errors.

Optional: Recursive Subdirectory Search #

If you need to search all subdirectories within the target directories, replace the file search loop with this recursive function:

Sub SearchFilesRecursive(ByVal currentDir As String, ByVal regex As Object, ByRef ws As Worksheet, ByVal rowNum As Long)
    Dim fileName As String
    Dim subDir As String
    Dim folderName As String
    
    ' Search files in current directory
    fileName = Dir(currentDir & "\*.*")
    Do While fileName <> ""
        If regex.Test(fileName) Then
            folderName = Split(currentDir, "\")(UBound(Split(currentDir, "\")))
            ws.Cells(rowNum, "B").Value = folderName
            Exit Sub ' Exit once match found
        End If
        fileName = Dir
    Loop
    
    ' Search subdirectories
    subDir = Dir(currentDir & "\*", vbDirectory)
    Do While subDir <> ""
        If subDir <> "." And subDir <> ".." Then
            If (GetAttr(currentDir & "\" & subDir) And vbDirectory) = vbDirectory Then
                SearchFilesRecursive currentDir & "\" & subDir, regex, ws, rowNum
                ' Exit if match found in subdirectory
                If ws.Cells(rowNum, "B").Value <> "" Then Exit Sub
            End If
        End If
        subDir = Dir
    Loop
End Sub

To use this function, replace the inner directory loop in the main script with:

For j = LBound(targetDirs) To UBound(targetDirs)
    currentDir = targetDirs(j)
    If Dir(currentDir, vbDirectory) <> "" Then
        SearchFilesRecursive currentDir, regex, ws, i
        If ws.Cells(i, "B").Value <> "" Then Exit For
    End If
Next j

内容的提问来源于stack exchange，提问作者InvkrMainr