通过正则提取单元格字符串生成表格的VBA开发问题

问题描述 #

我正在编写大型VBA宏，用于从工作表提取数据并转换到其他工作表，其他功能均正常，但卡在两个核心环节：

1. 目标单元格包含动态行数的多行文本（示例共11行，每行末尾以「空格+Alt+Enter」分隔），尝试通过统计换行符构建数组，但测试代码始终返回0；
2. 文本存在格式差异（部分行带货币符号，阈值表述有「above」和「>」两种形式），无法适配这些差异完成表格解析。

示例文本 #

Flat where a figure is quoted but theshold based on the following lanes
IL STD  $5.00 above $75.00 USD 
SG STD  $11 above SGD400 
TR STD  $3 above €30 EUR 
AU EXP $2 for value>AUD 1000
IL EXP $2 for value>USD 75
JP EXP $2 for value>USD 65
NZ EXP $2 for value>NZD 400
PH EXP $2 for value>USD 165
SG EXP $2 for value>SGD 400
TW EXP $2 for value>TWD 2000

测试代码 #

Sub tresholds()

Dim strTest As String
Dim NewLines As Long

strTest = ThisWorkbook.Sheets("Rate Card").Range("D10").Text
NewLines = UBound(Split(strTest, Chr(32) & vbCrLf))
'NewLines = UBound(Split(strTest, " " & vbCrLf))
'NewLines = UBound(Split(strTest, vbCrLf))
'NewLines = UBound(Split(strTest, vbLf))
'NewLines = UBound(Split(strTest, Chr(32) & vbLf))

Debug.Print NewLines

End Sub

解决方案 #

一、修复换行符统计返回0的问题 #

测试代码返回0的核心原因是分隔符匹配失败：Excel单元格中Alt+Enter生成的是vbLf（Chr(10)），而非vbCrLf；且部分行末尾的空格可能缺失或数量不一致，导致分割逻辑失效。

修改后的统计代码：

Sub CountLines()
    Dim strTest As String
    Dim lineArray As Variant
    Dim lineCount As Long
    
    strTest = ThisWorkbook.Sheets("Rate Card").Range("D10").Text
    ' 统一替换所有换行符为vbLf，避免混合换行的问题
    strTest = Replace(Replace(strTest, vbCrLf, vbLf), vbCr, vbLf)
    ' 移除每行末尾的空格，确保分割符是纯vbLf
    strTest = Trim(Replace(strTest, " " & vbLf, vbLf))
    
    lineArray = Split(strTest, vbLf)
    lineCount = UBound(lineArray) + 1 ' Split返回数组索引从0开始，总行数需+1
    
    Debug.Print "总行数：" & lineCount
End Sub

二、正则表达式解析文本为规范表格 #

针对文本格式差异，使用正则表达式匹配关键字段（地区、类型、费用、阈值货币、阈值金额），步骤如下：

1. 添加正则引用：打开VBA编辑器→点击「工具」→「引用」→勾选「Microsoft VBScript Regular Expressions 5.5」。
2. 解析代码：

Sub ParseToTable()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim strText As String
    Dim regEx As New RegExp
    Dim matches As MatchCollection, match As Match
    Dim i As Long
    
    ' 定义源表和目标表
    Set wsSource = ThisWorkbook.Sheets("Rate Card")
    Set wsTarget = ThisWorkbook.Sheets("解析结果") ' 需预先创建目标工作表
    
    ' 清空目标表现有数据（保留表头）
    If wsTarget.Cells(Rows.Count, "A").End(xlUp).Row >= 2 Then
        wsTarget.Range("A2:E" & wsTarget.Cells(Rows.Count, "A").End(xlUp).Row).ClearContents
    End If
    
    ' 获取单元格文本并统一换行符
    strText = wsSource.Range("D10").Text
    strText = Replace(Replace(strText, vbCrLf, vbLf), vbCr, vbLf)
    
    ' 配置正则表达式
    regEx.Pattern = "^([A-Z]{2}) ([A-Z]{3})\s*([$€]?\d+(?:\.\d+)?).*(?:above|>)\s*([A-Z]{3})?([$€]?\d+(?:\.\d+)?)"
    regEx.Global = True ' 全局匹配所有符合条件的行
    regEx.MultiLine = True ' 允许匹配多行文本
    
    ' 执行匹配
    Set matches = regEx.Execute(strText)
    
    ' 将匹配结果写入目标表格
    i = 2 ' 从第二行开始写入数据
    For Each match In matches
        wsTarget.Cells(i, "A").Value = match.SubMatches(0) ' 地区代码
        wsTarget.Cells(i, "B").Value = match.SubMatches(1) ' 类型（STD/EXP）
        wsTarget.Cells(i, "C").Value = match.SubMatches(2) ' 费用金额
        
        ' 处理阈值货币：优先取明确的货币代码，否则从金额符号推断
        If match.SubMatches(3) <> "" Then
            wsTarget.Cells(i, "D").Value = match.SubMatches(3)
        Else
            Select Case Left(match.SubMatches(4), 1)
                Case "$": wsTarget.Cells(i, "D").Value = "USD"
                Case "€": wsTarget.Cells(i, "D").Value = "EUR"
            End Select
        End If
        
        wsTarget.Cells(i, "E").Value = match.SubMatches(4) ' 阈值金额
        i = i + 1
    Next match
    
    MsgBox "解析完成，共处理 " & matches.Count & " 行数据"
End Sub

正则模式说明

• ^([A-Z]{2}) ([A-Z]{3})：匹配开头的两位地区代码（如IL、SG）和三位业务类型（STD/EXP）；
• \s*([$€]?\d+(?:\.\d+)?)：匹配费用金额，支持带$或€符号，兼容整数（如$11）和小数（如$5.00）；
• .*(?:above|>)：匹配连接费用与阈值的任意文本，精准定位到「above」或「>」这两个阈值标识；
• ([A-Z]{3})?([$€]?\d+(?:\.\d+)?)：匹配阈值的三位货币代码（可选，如USD/SGD）和阈值金额，适配带/不带货币符号的情况。

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