从文本中提取 2 个数字（批量列表）

Question

背景资料：

我有一个包含 5000 多条错误消息的列表，格式如下：

"999999 16 901 F SMITH, Smith FT 1 1.0 额外休假时间 -4.0000 超出应享权利加比例 -4.0000"

我已经能够使用宏对它们进行分类，例如“额外休假时间超过应享权利加上按比例分配”。

我试图从那里提取这两个数字。

我可以使用这些公式手动完成：

=MID(J3,SEARCH("hours ",J3)+5,SEARCH("exceed",J3)-SEARCH("hours ",J3)-6)
   
=TRIM(RIGHT(SUBSTITUTE(J3," ",REPT(" ",LEN(J3))),LEN((J3))))

但这就是我卡住的地方，将该逻辑合并到宏中并让它遍历整个列表。

这是我的第一次尝试：

If InStr(myString, "Additional Leave hours ") > 0 And InStr(myString, "exceed entitlement plus pro-rata") Then

'set category
Cells(x, 6).Value = "Additional Leave hours exceed entitlement plus pro-rata"

'first number
Cells(x, 8).ForumlaR1C1 = "=MID(RC[2],SEARCH(""hours "",RC[2])+5,SEARCH(""exceed"",RC[2])-SEARCH(""hours "",RC[2])-6"

'second number
Cells(x, 9).FormulaR1C1 = "=TRIM(RIGHT(SUBSTITUTE(RC[2],"" "",REPT("" "",LEN(RC[2]))),LEN((RC[2]))))"

'first minus second
Cells(x, 7).FormulaR1C1 = "=SUM(RC[2]-RC[1]"
    
End If

从那里我已经能够使用 .Select & .Active 单元格，它可以工作但效率不高：

'first number
Cells(x, 8).Select
        
ActiveCell.FormulaR1C1 = "=MID(RC[2],SEARCH(""hours"",RC[2])+5,SEARCH(""exceed"",RC[2])SEARCH(""hours "",RC[2])-6)"

任何帮助将不胜感激，在此先感谢。

Answer 1

想法是处理数组中的所有字符串（这样它更快，与 writing/reading 单元格 1 乘 1 相比），使用 RegExp 将 2 个数字提取到一个数组中，该数组将用于粘贴进入前两列。最后将SUM公式插入前一列：

Sub Test()
    Const inputStartRow As Long = 1
    Const inputCol As String = "J"
    Const regexPattern As String = "Additional Leave hours ([-\d.]{1,}) exceed entitlement plus pro-rata ([-\d.]{1,})"
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1") 'Change name accordingly
    
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    With regex
        .Pattern = regexPattern
        .Global = False
    End With
    
    '==== Get last row of the input column and set to range
    Dim inputLastRow As Long
    inputLastRow = ws.Cells(ws.Rows.Count, inputCol).End(xlUp).Row
        
    Dim inputRng As Range
    Set inputRng = ws.Range(ws.Cells(inputStartRow, inputCol), ws.Cells(inputLastRow, inputCol))
    
    '==== Populate the array with the input range's value
    Dim inputArr As Variant
    inputArr = inputRng.Value
        
    Dim outputArr() As String
    ReDim outputArr(1 To UBound(inputArr, 1), 1 To 2) As String
    
    '==== Loop through the array and extract the 2 numbers
    Dim i As Long
    For i = 1 To UBound(inputArr, 1)
        If InStr(inputArr(i, 1), "Additional Leave hours ") > 0 And InStr(inputArr(i, 1), "exceed entitlement plus pro-rata") Then
            If regex.Test(inputArr(i, 1)) Then
                Dim regexMatch As Object
                Set regexMatch = regex.Execute(inputArr(i, 1))(0)
                                
                outputArr(i, 1) = regexMatch.SubMatches(0)
                outputArr(i, 2) = regexMatch.SubMatches(1)
            End If
        End If
    Next i
    
    '==== Insert the extraction @ Input column - 1/ -2
    Dim outputRng As Range
    Set outputRng = inputRng.Offset(, -2).Resize(, 2)
    outputRng.Value = outputArr
    
    Set outputRng = Nothing
    
    '==== Add in SUM formula @ Input Column - 3
    Dim sumRng As Range
    Set sumRng = inputRng.Offset(, -3)
    sumRng.Formula = "=SUM(" & ws.Cells(inputStartRow, sumRng.Column + 1).Address(RowAbsolute:=False) & "-" & ws.Cells(inputStartRow, sumRng.Column + 2).Address(RowAbsolute:=False) & ")"
    
    Set sumRng = Nothing
End Sub

从文本中提取 2 个数字（批量列表）

Extract 2 numbers from text (bulk list)

excel

vba

text

numbers

extract