excel - 试图用 VBA 做一些奇怪的事情(奇怪的情况)

Question

我在 excel 中有 2 个选项卡，我对 VBA 有点陌生:
运营 :

详情 :


Excel View :



看看这个: “操作”选项卡中的说明字段将包含不同的“操作代码”(它可能包含 1 个操作代码、2 个操作代码或更多)。这是一个 11 位数字 .问题是这个字段是固定的，有时操作代码会被截断。

ONLY THOSE NUMBERS with exact amount of 11 digits must be considered

我想实现这一点:

VBA 应该从“操作”选项卡的“描述”单元格中找到每个事务。在这种情况下，第一行包含一个事务，第 2 行包含一个事务，第 3 行包含 2 个事务和 仅考虑 11 位以内的操作代码

它应该复制 号码 从选项卡“操作”并将其粘贴到选项卡“描述”中的“编号”列中

预期输出:


数据集:

|    NUMBER     |TYPE|  DESCRIPTION                    |SUMATORY_OF_MONEY
|B0001100005429 |FAC|   SADADECO 19278294999           |     
|A0001100001230 |REC|   ORDONEZC9920 19299490733       |    
|B0001100005445 |N/C|   IGN_GONTAN 19266048459 1929949 |    
|B0001100005445 |FAC|   IGN_GONTAN 19266048445 19299494|    
|B0001100005449 |FAC|   rer 19266048445 19266048223    |


|OPERATION_ID|  AMOUNT| NUMBER
|19278294999 |  4739  | 
|19299490733 |  9999  | 
|19266048459 |  34    | 
|19266048445 |  554   |
|19266048223 |  4444  | 

我试图做这样的事情:

Option Explicit
Sub M_snb()
    Dim vOps As Variant, vDets As Variant
    Dim rOps As Range, rDets As Range
    Dim re As Object, mc As Object, m As Object
    Dim I As Long, K As Long
    Dim vSum, vNumber
    
    
'initialize regex
    Set re = CreateObject("vbscript.regexp")
    With re
        .Global = True
        .Pattern = "(?:\D|\b)(\d{11})(?:\D|\b)"
    End With
    
'read data into variant array for faster processing
'also set the ranges for when we write the results back
With ThisWorkbook.Worksheets("Operations")
    Set rOps = .Cells(1, 1).CurrentRegion
    vOps = rOps
End With
With ThisWorkbook.Worksheets("Details")
    Set rDets = .Cells(1, 1).CurrentRegion
    vDets = rDets
End With

For I = 2 To UBound(vOps, 1)
    vOps(I, 4) = 0
    If re.test(vOps(I, 3)) = True Then
        Set mc = re.Execute(vOps(I, 3))
        For Each m In mc
            For K = 2 To UBound(vDets, 1)
                If m.submatches(0) = CStr(vDets(K, 1)) Then
                    vOps(I, 4) = vOps(I, 4) + vDets(K, 2)
                    vDets(K, 3) = vOps(I, 1)
                End If
            Next K
        Next m
    End If
Next I

'rewrite the tables
    
    With rOps
        .ClearContents
        .Value = vOps
    End With
    
    With rDets
        .ClearContents
        .Value = vDets
    End With

这是来自上一个问题: VBA tricky situation
你能帮我让它在VBA上工作吗？

Answer 1

编辑:进行了一些更改，包括换成非正则表达式模式匹配(仍然很快)。
对您的样本数据进行了测试。

Sub M_snb()
    
    Dim wsOps As Worksheet, wsDets As Worksheet
    Dim c As Range, col As Collection, v, m
    Dim dataOps, dataDets, rO As Long, rD As Long
    
    Set wsOps = ThisWorkbook.Worksheets("Operations")
    Set wsDets = ThisWorkbook.Worksheets("Details")
    
    dataOps = wsOps.Range("A1").CurrentRegion.Value
    dataDets = wsDets.Range("A1").CurrentRegion.Value
    
    For rO = 2 To UBound(dataOps, 1)
        Set col = AllNumbers(dataOps(rO, 3))
        For Each v In col
            For rD = 2 To UBound(dataDets, 1)
                If CStr(dataDets(rD, 1)) = v Then
                    dataDets(rD, 3) = dataOps(rO, 1)
                    dataOps(rO, 4) = dataOps(rO, 4) + dataDets(rD, 2)
                End If
            Next rD
        Next v
    Next rO
    
    DropArray dataOps, wsOps.Range("A1")
    DropArray dataDets, wsDets.Range("A1")
End Sub

'return all 11-digit strings in v as a Collection
Function AllNumbers(v) As Collection
    Const NUM_DIGITS As Long = 11
    Dim m As Object, mc As Object, col As New Collection, txt, i As Long, patt, ss
    txt = " " & v & " "
    patt = String(NUM_DIGITS, "#")
    i = 2
    For i = 2 To Len(txt) - NUM_DIGITS
        ss = Mid(txt, i, 11)
        If ss Like patt Then
            If Not Mid(txt, i - 1, 1) Like "#" Then
                If Not Mid(txt, i + NUM_DIGITS, 1) Like "#" Then
                    col.Add ss
                End If
            End If
        End If
    Next i
    Set AllNumbers = col
End Function

'Utility method: put a 2d array on a sheet at rng
Sub DropArray(arr, rng As Range)
    rng.Cells(1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub