从邮件正则匹配结果获取SubMatches填充Excel单元格问题

原代码存在的核心问题 #

• 未获取Outlook中选中的邮件：olItem变量未赋值，无法读取目标邮件内容
• 正则表达式缺少捕获组：原Pattern未添加括号，导致SubMatches无数据可提取；且原Pattern仅匹配单个汇率格式，无法区分买入、卖出、中间价
• 正则逻辑对象混淆：第二个正则判断和执行错误使用了Reg1对象，而非Reg2
• 未将提取结果写入Excel单元格：仅完成变量赋值，未输出到指定位置
• 变量声明不规范：多变量声明时仅最后一个变量为String类型，前两个为Variant类型

修正后的VBA代码 #

Sub data_from_email()
    Dim olItem As Outlook.MailItem
    Dim olApp As Outlook.Application
    Dim wb As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim KSell As String, KBuy As String, KAvr As String ' 修正变量声明
    Dim sText As String
    Dim Reg As Object ' 合并正则对象，简化逻辑
    Dim matches As Object
    Dim match As Object
    
    ' 绑定当前Excel工作簿和指定工作表
    Set wb = ThisWorkbook
    Set xlSheet = wb.Sheets("name") ' 确保此处工作表名称与实际一致
    
    ' 初始化Outlook并获取选中的邮件
    Set olApp = New Outlook.Application
    ' 判断是否有邮件被选中
    If olApp.ActiveExplorer.Selection.Count = 0 Then
        MsgBox "请先在Outlook中选中一封包含汇率的邮件！"
        Exit Sub
    End If
    Set olItem = olApp.ActiveExplorer.Selection.Item(1)
    sText = olItem.Body
    
    ' 正则匹配：兼容点/逗号作为分隔符，匹配三组汇率（需根据实际邮件文本调整前缀描述）
    ' 示例假设邮件文本格式为："中间价:1.2345 买入价:6.7890 卖出价:3.4567"
    Set Reg = CreateObject("vbscript.regexp")
    With Reg
        .Pattern = "中间价:(\d[\.,]\d{4}).*买入价:(\d[\.,]\d{4}).*卖出价:(\d[\.,]\d{4})"
        .Global = False ' 仅匹配一组汇率数据
        .IgnoreCase = True
    End With
    
    ' 执行匹配并写入Excel单元格
    If Reg.Test(sText) Then
        Set matches = Reg.Execute(sText)
        Set match = matches(0)
        KAvr = match.SubMatches(0) ' 对应第一个捕获组（中间价）
        KBuy = match.SubMatches(1) ' 对应第二个捕获组（买入价）
        KSell = match.SubMatches(2) ' 对应第三个捕获组（卖出价）
        
        ' 将数据写入指定单元格，统一替换逗号为点以便Excel识别为数值
        xlSheet.Range("A1").Value = Replace(KAvr, ",", ".")
        xlSheet.Range("B1").Value = Replace(KBuy, ",", ".")
        xlSheet.Range("C1").Value = Replace(KSell, ",", ".")
    Else
        MsgBox "未在选中邮件中找到符合格式的汇率数据！"
    End If
    
    ' 释放对象
    Set olItem = Nothing
    Set olApp = Nothing
    Set xlSheet = Nothing
    Set wb = Nothing
    Set Reg = Nothing
    Set matches = Nothing
    Set match = Nothing
End Sub

关键说明 #

1. 选中邮件校验：添加了选中状态判断，避免无邮件时报错
2. 正则逻辑优化：合并两个正则为一个，通过[\.,]兼容两种分隔符；添加捕获组区分三类汇率，需根据实际邮件中的汇率前缀（如“现汇买入价”）调整Pattern内的文本描述
3. 单元格写入处理：将提取的汇率值写入指定单元格，并替换逗号为点，确保Excel能识别为数值类型
4. 错误提示：添加了无选中邮件、无匹配数据的提示，提升宏的易用性

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