如何在VBA中提取方括号间字符串以更新工作簿链接？

问题描述 #

我正尝试自动化更新指向其他工作簿的链接源，但遇到了问题。已成功找到最新版本的Fleet Count文件，但需要将代码底部的Name变量设置为当前链接的实际文件名。思路是用正则表达式：当前活动工作簿的某个单元格包含当前链接的工作簿路径：='S:\US\Projections\2022\Fleet Count[Fleet Count Projection 07Act08Fv2.xlsm]!Sheet$HZ4，只需提取方括号之间的字符串即可实现所需功能。现有代码如下：

Sub Update_FleetCount_Link()

    'Declare the variables
    Dim MyPath As String
    Dim MyFile As String
    Dim LatestFile As String
    Dim LatestDate As Date
    Dim LMD As Date
    
    'Specify the path to the folder
    MyPath = "S:\US\Projections\2022\Fleet Count\"
    
    'Make sure that the path ends in a backslash
    If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
    
    'Get the first Excel file from the folder
    MyFile = Dir(MyPath & "*.xlsm", vbNormal)
    
    'If no files were found, exit the sub
    If Len(MyFile) = 0 Then
        MsgBox "No files were found...", vbExclamation
        Exit Sub
    End If
    
    'Loop through each Excel file in the folder
    Do While Len(MyFile) > 0
    
        'Assign the date/time of the current file to a variable
        LMD = FileDateTime(MyPath & MyFile)
        
        'If the date/time of the current file is greater than the latest
        'recorded date, assign its filename and date/time to variables
        If LMD > LatestDate Then
            LatestFile = MyFile
            LatestDate = LMD
        End If
        
        'Get the next Excel file from the folder
        MyFile = Dir
        
    Loop
    
    'Change link to latest file in folder
    ActiveWorkbook.ChangeLink Name:= _
        MyPath & **???**, _
        NewName:=MyPath & LatestFile, Type:=xlExcelLinks
End Sub

解决方案 #

要提取方括号间的文件名并完成链接更新，按以下步骤修改代码：

1. 启用正则表达式引用：打开VBA编辑器，点击工具→引用，勾选Microsoft VBScript Regular Expressions 5.5。
2. 添加提取逻辑：新增正则相关变量，从指定单元格读取链接文本并解析出旧文件名。
3. 替换占位符：将ChangeLink方法中的???替换为提取到的旧文件名。

修改后的完整代码：

Sub Update_FleetCount_Link()

    'Declare the variables
    Dim MyPath As String
    Dim MyFile As String
    Dim LatestFile As String
    Dim LatestDate As Date
    Dim LMD As Date
    Dim regex As New RegExp
    Dim linkText As String
    Dim oldFileName As String
    
    'Specify the path to the folder
    MyPath = "S:\US\Projections\2022\Fleet Count\"
    
    'Make sure that the path ends in a backslash
    If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
    
    'Get the first Excel file from the folder
    MyFile = Dir(MyPath & "*.xlsm", vbNormal)
    
    'If no files were found, exit the sub
    If Len(MyFile) = 0 Then
        MsgBox "未找到任何文件...", vbExclamation
        Exit Sub
    End If
    
    'Loop through each Excel file in the folder
    Do While Len(MyFile) > 0
    
        'Assign the date/time of the current file to a variable
        LMD = FileDateTime(MyPath & MyFile)
        
        'If the date/time of the current file is greater than the latest
        'recorded date, assign its filename and date/time to variables
        If LMD > LatestDate Then
            LatestFile = MyFile
            LatestDate = LMD
        End If
        
        'Get the next Excel file from the folder
        MyFile = Dir
        
    Loop
    
    '从指定单元格获取链接文本（请替换为实际存放链接的单元格）
    linkText = ThisWorkbook.Sheets("Sheet1").Range("A1").Formula
    
    '设置正则规则：匹配方括号内的文件名
    regex.Pattern = "\[([^\]]+)\]"
    regex.Global = False
    
    '提取旧文件名
    If regex.Test(linkText) Then
        oldFileName = regex.Execute(linkText)(0).SubMatches(0)
    Else
        MsgBox "指定单元格未找到有效链接格式", vbExclamation
        Exit Sub
    End If
    
    '更新链接为最新文件
    ActiveWorkbook.ChangeLink Name:= _
        MyPath & oldFileName, _
        NewName:=MyPath & LatestFile, Type:=xlExcelLinks
        
    MsgBox "链接已更新为最新文件：" & LatestFile, vbInformation
End Sub

关键说明 #

• 正则表达式：\[([^\]]+)\] 精准匹配方括号[]之间的内容，确保只提取文件名。
• 单元格替换：务必把ThisWorkbook.Sheets("Sheet1").Range("A1")改成实际存放链接的单元格位置。
• 错误提示：新增了格式校验，避免因单元格内容异常导致代码报错。

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