VBA - Split the data

[Mallesh23]

Hi Team,

Column A is a Consolidated Invoices of different Country's Company. different style of drafting.

Now task is extract Invoices separately. Expected Output is in Column B.

I am Unable to split the data as Column A data is not a standard one.

Looking for a Macro. Thanks.

Sample dummy data

Book1
	A	B
1	Invoice	Expected Invoice
2	5300000798-PIF-PR	5300000798
3	7350001120 RW BAL	7350001120
4	5100000182-Bal-20	5100000182
5	D-PR-10967-315000492	315000492
6	F-W-10713-3150004797
7	2333-RW-4400000176-P	4400000176
8	6200110592	6200110592
9	7800000292-8451-P	7800000292
10	635011186 - 10 - p	635011186
11	D-ED-10566-315000470	315000470
12	F-W-10488-3150004700	3150004700
13	5650000669/W&D/DEP	5650000669
14	5650000671/W&D/DEP	5650000671
15	5650000606 fnl pmt S	5650000606
16	5750000669-bal-35	5750000669
17	refu25188/6000000502	6000000502
18	9161/4750000388/vs/p	4750000388
19	F-ED-9861-3150004404	3150004404
20	6550000757fp10	6550000757
21	9202/4750000419/VS/P	4750000419
22	7250000387RWDEP	7250000387
23	9619/4750000712/RW/C	4750000712
24	F-W-10455-3150004682	3150004682
25	D-W-11009-3150004941	3150004941
26	61001540222366-10-P	6.10015E+13
27	6200000780	6200000780
28	F-RW-10212-0004571
29	P25132/6000000466 RW	6000000466
30	2365-ED-4400000196-D	4400000196
31	24903 RW/PP (ML)
32	6550000363dp10	6550000363
33	5492693164965788	5492693164965788
34	6350000532 - 10 - D	6350000532
35	6550000882dp30	6550000882
36	D/P/5050000791-16762	5050000791
37	f-sr-3150003955-8853	3150003955
38	6150000163/Refunded Dep/Cancelled Contract/10	6150000163
39	AX41500003618	41500003618
40	4150000330 - D
41	24318 PR/PO
42	4300001631 - 10 - P	4300001631
43	DP-PR-#2394-281
Sheet1

Thanks
mg

 

[Peter_SSs]

I can't see the logic as to why some rows get a value in the Expected Invoice column and some do not. You have given no explanation about how we would decide what is an invoice number and what is not.

 

[Mallesh23]

Hi Peter,

after splitting a cell , Invoice should be in no, if multiple numbers after split then Number which has highest Len(Numbers) will be accurate invoice
if cell value Blank - No Output for that cell.


Thanks.
mg

 

[Phuoc]

Try this:

Public Function ExtractInvoices(ByVal s As String) As String
Dim i As Long, k As Long, v As Variant
For i = 1 To Len(s)
    If IsNumeric(Mid(s, i, 1)) = False Then Mid(s, i, 1) = " "
Next
For Each v In Split(Application.Trim(s), " ")
    If Len(v) > k Then
        k = Len(v)
        ExtractInvoices = v
    End If
Next

End Function

 

[Mallesh23]

Hi Phuoc

Thanks for your help, My data is 50000 records. but still it worked. it is giving correct output as asked.


Thanks
mg

 

[Peter_SSs]

it worked.

OK, that indicates that the blank cells in column B of post 1 should not have been blank - that was one of the things I was asking about before.

If you want the results to be dynamic (that is a function), this is a little faster but not by a huge amount. For me with 50,000 rows about 1.2 seconds for this function v about 2.0 seconds for Phuoc's function.

Function InvoiceNum(s As String) As String
  Static RX As Object
  Dim itm As Variant
  
  If RX Is Nothing Then
    Set RX = CreateObject("VBScript.RegExp")
    RX.Global = True
    RX.Pattern = "\d+"
  End If
  For Each itm In RX.Execute(s)
    If Len(itm) > Len(InvoiceNum) Then InvoiceNum = itm
  Next itm
End Function

If you don't need the results to be dynamic, then this is much faster (0.25 seconds for me on the same data)

Sub Get_Invoices()
  Dim RX As Object
  Dim a As Variant, itm As Variant
  Dim tmp As String
  Dim i As Long
  
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = "\d+"
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
  For i = 1 To UBound(a)
    tmp = vbNullString
    For Each itm In RX.Execute(a(i, 1))
      If Len(itm) > Len(tmp) Then tmp = itm
    Next itm
    a(i, 1) = tmp
  Next i
  With Range("B2").Resize(UBound(a))
    .NumberFormat = "@"
    .Value = a
  End With
End Sub

 

[Mallesh23]

Hi Peter,

Wow !! this is amazing piece of code, tested and it worked. ?

Can you please add a comment to know how it works.

Thanks
mg

 

[Peter_SSs]

Can you please add a comment to know how it works.

If you are not familiar with 'Regular Expressions' (VBScript.RegExp) then you might need to do some research on that. The RegExp looks for patterns in a string. The pattern I set, "\d+", simply looks for 1 or more digits in a row. The code then looks through any such matches and gets the longest one.

 

[Rick Rothstein]

If the number being retrieved will not be longer than 15 digits, this function should also work...

Function ExtractInvoices(ByVal S As String) As String
  Dim X As Long
  For X = 1 To Len(S)
    If Mid(S, X, 1) Like "[!0-9]" Then Mid(S, X) = " "
  Next
  ExtractInvoices = Evaluate("MAX(" & Replace(Application.Trim(S), " ", ",") & ")")
End Function

 

[Peter_SSs]

this function should also work...

The OP stated that the previous functions/code worked. I think that your functions fails each of these points

Number which has highest Len(Numbers) will be accurate invoice

See row 28 of the sample data

if cell value Blank - No Output for that cell.

A similar function to yours that I believe would work is as below, though I think the problem with a udf for this with 50,000 records is a calculation speed one, hence my non-udf suggestion above.

Function ExtractInvoice(ByVal S As String) As String
  Dim X As Long
  For X = 1 To Len(S)
    If Mid(S, X, 1) Like "[!0-9]" Then Mid(S, X) = ","
  Next
  ExtractInvoice = Mid(Evaluate("MAX(1," & Replace(S, ",", ",1") & ")"), 2)
End Function