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:
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
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?
CodePudding user response：
Untested but I'd probably start like this:
Sub M_snb()
Dim wsOps As Worksheet, wsDets As Worksheet
Dim c As Range, col As Collection, v, m
Set wsOps = ThisWorkbook.Worksheets("Operations")
Set wsDets = ThisWorkbook.Worksheets("Details")
For Each c In wsOps.Range("C2:C" & wsOps.Cells(Rows.Count, "C").End(xlUp).Row).Cells
Set col = AllMatches(c.Value)
For Each v In col
m = Application.Match(v, wsDets.Columns("A"), 0)
If Not IsError(m) Then
wsDets.Cells(m, "C").Value = wsOps.Cells(c.Row, "A").Value
With wsOps.Cells(c.Row, "D")
.Value = .Value wsDets.Cells(m, "B").Value
End With
End If
Next v
Next c
End Sub
'return all 11-digit strings in v as a Collection
Function AllMatches(v) As Collection
Static re As Object
Dim m As Object, mc As Object, col As New Collection, txt
If re Is Nothing Then 'create configure regex object if not previously created
Set re = CreateObject("vbscript.regexp")
With re
.Global = True
.Pattern = "\D(\d{11})\D"
End With
End If
txt = " " & v & " " 'padding to cheat a bit on the pattern...
If re.test(txt) Then
Set mc = re.Execute(txt)
For Each m In mc 'collect all matches
col.Add m.submatches(0)
Next m
End If
Set AllMatches = col
End Function
CodePudding user response：
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
Public Sub CompileTableDetails(ByRef ipOperations As Excel.Range, ByRef ipDetails As Excel.Range, ByRef 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
ipOutPut.Value = myD.Items
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(myOperations(myRow, colDesc), " ")
Dim myItem As Variant
For Each myItem In myDesc
If IsValidOperationCode(myItem) Then
If Not iopDictionary.Exists(myItem) Then
iopDictionary.Add myItem, Array(myItem, Empty, ipOperations(myRow, colNumber))
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
' 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
iopDictionary.Item(myOperationId) = iopDictionary(myOperationId) CLng(myDetails(myRow, colAmount)) ' CLng may need to be CDbl
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