Trying to make some weird things with VBA (strange situation)

Question

I got 2 tabs in excel and i am kinda new to VBA:

Operations:

Details:

---

Excel view:

---

Take a look at this: DESCRIPTION field from tab "Operations" will contain different "operation codes" (it may contain 1 operation code, 2 operation codes or much more). It is a 11-DIGIT number . The problem is that this field is fixed and sometimes the operation code is truncated.

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

I WANT TO ACHIEVE THIS:

1. VBA SHOULD FIND EVERY TRANSACTION INSIDE "DESCRIPTION" CELL FROM TAB "OPERATIONS". IN THIS CASE THE FIRST ROW CONTAINS ONE TRANSACTION, ROW 2 CONTAINS ONE TRANSACTION AND ROW 3 CONTAINS 2 TRANSACTIONS AND ONLY CONSIDER THE OPERATION CODES WITHIN 11 DIGITS

2. IT SHOULD COPY THE NUMBER FROM TAB "OPERATIONS" AND PASTE IT INSIDE COLUMN "NUMBER" FROM TAB "DESCRIPTION"

Expected output:

---

dataset:

|    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  | 

I was trying to do something like this:

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

This is from a previous question: VBA tricky situation

Could you please help me to make it work on VBA?

Answer 1

Again an untested solution. One that moves data into VBA arrays for processing and consequently avoids the use of Regex. I don't use excel so some of the excel related code (particularly pasting the results back) may need tweaking.

After posting I realised that the Items method will return a jagged array. This just means you have to loop through the dictionary using for each and paste each row in turn back into excel. To follow many really really irritating authors, this activity is left as an exercise for the reader.

Option Explicit


Sub Test()

    CompileTableDetails ActiveSheet.Range("A2:C6"), ActiveSheet.Range("G2:H6"), ActiveSheet.Range("A8")
End Sub

Public Sub CompileTableDetails(ByRef ipOperations As Excel.Range, ByRef ipDetails As Excel.Range, ByVal ipOutPut As Excel.Range)

     ' A scripting.dictionary is used to collate information
    ' it allows the uniqueness of the 11 digit codes to be checked
    ' it allows us to provide an array of final results for pasting back into excel
    ' either add a reference to the microsoft scripting runtime
    ' or use Createobject("Scripting.Dictionary")
    Dim myD As Scripting.Dictionary
    Set myD = New Scripting.Dictionary
    
    CompileOperationId ipOperations, myD
    CompileAmounts ipDetails, myD
    
    ' We can now paste the Items of the scripting.dictionary back into excel
    ' but because Items is a jagged array (array of arrays) we need to do this
    ' row by row
    
    Dim myRowOffset As Long
    myRowOffset = 0
    
    ' Select the top left hand corner of the area we will paste into
    ipOutPut.Select
    
    ' now paste row by row
    Dim myItem As Variant
    For Each myItem In myD.Items
    
        Range(ActiveCell.Offset(myRowOffset, 0), ActiveCell.Offset(myRowOffset, 2)) = myItem
        myRowOffset = myRowOffset + 1
        
    Next

End Sub


Public Sub CompileOperationId(ByRef ipOperations As Excel.Range, ByRef iopDictionary As Scripting.Dictionary)
    
    ' Constants to avoid using 'Magic' numbers when referring to columns in arrays
    ' NOTE: Arrays read in from Excel have a lower bound of 1
    ' Operations Tab
    Const colNumber                 As Long = 1
    Const colType                   As Long = 2
    Const colDesc                   As Long = 3
   
    ' First process the operations aarray
    ' Extract operation codes and populate the dictionary using operation codes as the key
    ' Get the Excel Range as a VBA array
    Dim myOperations As Variant
    myOperations = ipOperations.Value
    
    Dim myRow As Long
    For myRow = LBound(myOperations, 1) To UBound(myOperations, 1)
    
        ' Split the Description column into subfields at the spaces
        ' NOTE: Arrays read in from Excel have the indexing reversed compared to Excel col,row referencing e.g. Cell "B5" is Array(5,2)
        
        ' Split the contents of the Description Cell at the ' ' to get an array of substrings
        ' some of the substrings will be an 11 digit numeric code
        Dim myDesc As Variant
        myDesc = Split(Trim$(myOperations(myRow, colDesc)), " ")
        
        Dim myItem As Variant
        For Each myItem In myDesc
        
            If IsValidOperationCode(Trim$(myItem)) Then
            
                If Not iopDictionary.Exists(myItem) Then
                    Dim myArray As Variant
                    myArray = Array(myItem, Empty, ipOperations(myRow, colNumber).Value)
                    iopDictionary.Add myItem, myArray
            
                End If
                
            End If
            
        Next
    
    Next
    
End Sub
    
    
Public Sub CompileAmounts(ByRef ipDetails As Excel.Range, iopDictionary As Scripting.Dictionary)
    ' The scripting dictionary is popuulated with 11 digit operation codes
    ' now to use the Details array to compile the amounts
     ' Dictionary array
    Const colNumber                 As Long = 0
    Const colSumAmount              As Long = 1
    Const colDesc                   As Long = 2
    
    ' Details tab
    Const colOperationId            As Long = 1
    Const colAmount                 As Long = 2
    
    ' Get the excel range as a VBA array
    Dim myDetails As Variant
    myDetails = ipDetails.Value
    
    Dim myRow As Long
    For myRow = LBound(myDetails, 1) To UBound(myDetails, 1)
    
        Dim myOperationId As String
        myOperationId = Trim$(myDetails(myRow, colOperationId))
        
        If iopDictionary.Exists(myOperationId) Then
            ' we cannot change values in an array held by a dictionary
            ' so we have to read it then rewite it
            
            Dim myArray As Variant
            myArray = iopDictionary.Item(myOperationId)
            myArray(colSumAmount) = myArray(colSumAmount) + CLng(Trim$(myDetails(myRow, colAmount)))
            iopDictionary.Item(myOperationId) = myArray
            Debug.Print CLng(iopDictionary.Item(myOperationId)(colSumAmount)) + CLng(Trim$(myDetails(myRow, colAmount)))
            
        Else
        
            ' Add the amount but flag the NUmber as missing
            iopDictionary.Add myOperationId, Array(myOperationId, myDetails(myRow, colAmount), "Missing")
            
        
        End If
        
    Next
    
End Sub


Private Function IsValidOperationCode(ByVal ipString As String) As Boolean

    IsValidOperationCode = False
    If Len(ipString) <> 11 Then Exit Function
    IsValidOperationCode = IsNumeric(ipString)
    
End Function

Upate Thanks to the excel data being posted I was able to test the code I provided and a couple of updates were required. The code above has been updated.

The most insidious issue (which I'd forgotten about) was that you cannot write to an array held by a dictionary because the item method provides a copy of the array. So to do the amount addition it is necessary to read out the array into a variant, do the addition, then push the array back.

I've also added code to do the output.