Excel VBA解析文件名提取地址变更：适配多格式需求求助

Hey there! Let's fix up your VBA script to handle more filename formats and cut down on those yellow-highlighted unparsed entries. Here's an optimized solution with better flexibility and error handling:

• Use Regular Expressions: Regex is way more flexible than fixed-position cuts or simple string searches—it can handle variations in how old/new addresses are separated (like "to", "→", "from...to", etc.)
• Expand Prefix Matching: Cover more common naming prefixes instead of just two hardcoded ones
• Graceful Error Handling: Even if full parsing fails, extract whatever valid info we can instead of just dumping the whole filename
• Avoid Select/Activate: Direct cell assignment is faster and more reliable than navigating with selections

Sub ParseAddressChangeFiles()
    Dim AddChng As Worksheet
    Dim StrFile As String
    Dim regex As Object
    Dim matches As Object
    Dim oldAddr As String, newAddr As String
    Dim lastRow As Long
    
    ' Check if AddressChange sheet exists, create if not
    If sheetExists("AddressChange") Then
        Set AddChng = ThisWorkbook.Sheets("AddressChange")
    Else
        Set AddChng = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
        AddChng.Name = "AddressChange"
    End If
    
    ' Clear existing data and set headers
    AddChng.UsedRange.Delete shift:=xlUp
    AddChng.Range("A1:B1").Value = Array("Old Name", "New Name")
    
    ' Initialize regex object for pattern matching
    Set regex = CreateObject("VBScript.RegExp")
    regex.IgnoreCase = True
    regex.Global = False
    
    ' Regex pattern to match "Old Address to New Address" (handles common separators)
    ' Matches: [any text] [old addr] (to|→|->) [new addr] [any text/file extension]
    regex.Pattern = "(?:.*?)([\w\s\.,'-]+?)\s*(?:to|→|->)\s*([\w\s\.,'-]+?)(?:\.[a-zA-Z0-9]{3,4})?$"
    
    ' Get folder path from named range
    StrFile = Dir(Range("AddressChangeFolderPath").Value & "\*.*")
    
    lastRow = 2 ' Start writing from row 2
    
    Do While Len(StrFile) > 0
        oldAddr = ""
        newAddr = ""
        
        ' Check if filename contains address change keywords
        If StrFile Like "*Address Change*" Or StrFile Like "*Addr Change*" Then
            ' Try to match with regex first
            Set matches = regex.Execute(StrFile)
            
            If matches.Count > 0 Then
                oldAddr = Trim(matches(0).SubMatches(0))
                newAddr = Trim(matches(0).SubMatches(1))
                
                ' Write valid parsed data
                AddChng.Cells(lastRow, 1).Value = oldAddr
                AddChng.Cells(lastRow, 2).Value = newAddr
            Else
                ' Fallback: Manual search for "to" separator
                Dim toPos As Integer
                toPos = InStr(1, StrFile, "to", vbTextCompare)
                
                If toPos > 0 Then
                    ' Extract and clean old address
                    oldAddr = Trim(Left(StrFile, toPos - 1))
                    oldAddr = Replace(oldAddr, "Address Change Circulation -", "")
                    oldAddr = Replace(oldAddr, "Address Change Circulation from ", "")
                    oldAddr = Trim(oldAddr)
                    
                    ' Extract and clean new address (remove file extension)
                    newAddr = Trim(Right(StrFile, Len(StrFile) - toPos - 2))
                    newAddr = Left(newAddr, InStrRev(newAddr, ".") - 1)
                    newAddr = Trim(newAddr)
                    
                    AddChng.Cells(lastRow, 1).Value = oldAddr
                    AddChng.Cells(lastRow, 2).Value = newAddr
                Else
                    ' Full parse failed—mark cell yellow and keep filename
                    AddChng.Cells(lastRow, 1).Value = StrFile
                    AddChng.Cells(lastRow, 1).Interior.Color = RGB(255, 255, 0)
                End If
            End If
        Else
            ' Optional: Uncomment below to mark non-relevant files (gray background)
            ' AddChng.Cells(lastRow, 1).Value = StrFile
            ' AddChng.Cells(lastRow, 1).Interior.Color = RGB(200, 200, 200)
        End If
        
        lastRow = lastRow + 1
        StrFile = Dir
    Loop
    
    ' Auto-fit columns for readability
    AddChng.Columns("A:B").AutoFit
    
    MsgBox "Parsing complete! Please review the table for any yellow-highlighted entries that need manual adjustment."
End Sub

' Helper function to check if a sheet exists in the workbook
Function sheetExists(sheetName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(sheetName)
    On Error GoTo 0
    sheetExists = Not ws Is Nothing
End Function

• Regex Pattern: The regex is designed to handle multiple separator types and ignore irrelevant prefixes/suffixes. It captures address text that includes letters, spaces, commas, periods, apostrophes, and hyphens—common characters in addresses.
• Flexible Prefix Detection: Uses Like operators to catch any filename with "Address Change" or "Addr Change", so it works with more naming variants.
• Fallback Logic: If regex fails, it falls back to manual "to" searching and cleans up common prefixes/suffixes to extract usable data.
• No More Select/Activate: Directly writes to cells using AddChng.Cells(lastRow, 1).Value which eliminates runtime errors from sheet navigation and speeds up execution.
• Helper Function: Added sheetExists to properly validate the target sheet (your original code referenced this function but didn't define it).

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