20170624xlVBA正则分割分类汇总

Posted 2020-09-27

Sub RegExpSubtotal()

    ‘声明变量
    Dim Regex As Object ‘正则对象
    Dim Dic As Object ‘字典对象
    Dim Key As String ‘关键字
    Dim Item As Double ‘项内容
    Dim Index As Long ‘序号
    Dim Text As String ‘文本
    Dim Mch As Object ‘匹配集合
    Dim OneMch As Object ‘匹配子项
    Dim Rng As Range ‘单元格对象
    
    ‘实例化 正则对象和字典对象
    Set Regex = CreateObject("VBScript.RegExp")
    Set Dic = CreateObject("Scripting.Dictionary")
    

    With Regex
        .Global = True
        ‘匹配模式   浙江4000安徽19963.78
        Pattern = "([^\d\.]+)([\d\.]+)"
        .Pattern = Pattern
    End With
   
    ‘逐行循环收款明细
    For Index = 2 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
        Text = Cells(Index, "A").Text    ‘取得文本
        Set Mch = Regex.Execute(Text)  ‘执行匹配
        
        For Each OneMch In Mch ‘循环匹配集合
            Key = OneMch.SubMatches(0) ‘客户名称
            Item = CDbl(OneMch.SubMatches(1)) ‘收款金额
            Dic(Key) = Dic(Key) + Item ‘分类汇总
        Next OneMch

    Next Index
   
    ‘快速转置输出分类汇总内容
    Set Rng = Range("C1").Resize(Dic.Count, 2)
    Rng.Value = Application.WorksheetFunction.Transpose(Array(Dic.Keys, Dic.Items))
    
    ‘释放对象
    Set Regex = Nothing
    Set Dic = Nothing
    Set Rng = Nothing

End Sub