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

 

[Mallesh23]

Hi Peter/Rick

Thank you so much for giving multiplt ways of doing task.

I have similar Task2 , here I want to extract two digit no from a string.
as per Criteria list in Column D.

Find Which Product code has come in invoice, from Criteria list.
and Seperate it into Column D.

Column- A Input Data
Column - B Expected Output.
Column - D Criteria.

Below data with output

Book1 (version 2).xlsb
	A	B	C	D	E
1	Invoices	Product code		Product code Criteria	Meaning
2	7350002095-17661-10-bal	10		10	Laptop
3	7550001171 30 REF	30		30	Desktop
4	5500001065-10-DEP-17642	10		35	desktop
5	5100001456-10Dep-10010	10		20	Tab
6	5100001662-10PIF-9945	10
7	5100001577-35PIF-9831	35
8	6450000141-35-PIF	35
9	4300122304 - 20 - P	20
10	5650000619/15334 F W	-	No two digit here or Product code not found
11		-	no data leave blank/dash either
12	5010001010dp35	35
13	5010000955fp10	10
14	5010000016fp10	10
15	5010001013dp10	10
16	5010001014dp10/20	10/or20	First one /Either of it/ blank
Sheet2

Thanks
mg

 

[Peter_SSs]

I have assumed large data again & no need to be dynamic.
Also assumed that product codes do not start with a zero. If they can, then a modification can be made.

See if this does what you want. Per your notes on the last example, this will return the first 2-digit set.

Sub Get_Product_Code()
  Dim RX As Object
  Dim a As Variant, b As Variant
  Dim i As Long
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = "(^|\D)(\d\d)(\D|$)"
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    If RX.Test(a(i, 1)) Then b(i, 1) = RX.Execute(a(i, 1))(0).submatches(1)
  Next i
  Range("B2").Resize(UBound(a)).Value = b
End Sub

 

[Peter_SSs]

Oops, didn't take account of "No two digit here or Product code not found"

This version should allow for that (return blank). If there are more than one product codes found then this will return the last one, but that still fits with your requirement I believe.

Sub Get_Product_Code_v2()
  Dim RX As Object
  Dim a As Variant, b As Variant, itm As Variant
  Dim i As Long
  Dim ProdCodes As String
  
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = "(^|\D)(\d\d)(?=\D|$)"
  ProdCodes = "|" & Join(Application.Transpose(Range("D2", Range("D" & Rows.Count).End(xlUp))), "|") & "|"
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    For Each itm In RX.Execute(a(i, 1))
      If InStr(1, ProdCodes, "|" & itm.submatches(1) & "|") > 0 Then b(i, 1) = itm.submatches(1)
    Next itm
  Next i
  Range("B2").Resize(UBound(a)).Value = b
End Sub

Mallesh23 2020-08-13 1.xlsm
	A	B	C	D	E
1	Invoices	Product code		Product code Criteria	Meaning
2	7350002095-17661-10-bal	10		10	Laptop
3	7550001171 30 REF	30		30	Desktop
4	5500001065-10-DEP-17642	10		35	desktop
5	5100001456-10Dep-10010	10		20	Tab
6	5100001662-10PIF-9945	10
7	5100001577-35PIF-9831	35
8	6450000141-35-PIF	35
9	4300122304 - 20 - P	20
10	5650000619/15334 F W		No two digit here or Product code not found
11			no data leave blank/dash either
12	5010001010dp35	35
13	5010000955fp10	10
14	5010000016fp10	10
15	5010001013dp10	10
16	5010001014dp10/20	20	First one /Either of it/ blank
17	5010000016fp15		No product code found
18	5010000016fp20/16	20	multiple 2-digits but one is not product code
19	5010000016fp16/20/17/10	10	multiple 2-digits but some not product codes
Sheet2

 

[Mallesh23]

Hi Peter

Really amazing Thanks once again, I am excited to learn Regular experssion now.

Please can you comment below line to understand what it is doing.

RX.Pattern = "(^|\D)(\d\d)(?=\D|$)"
If InStr(1, ProdCodes, "|" & itm.submatches(1) & "|") > 0 Then b(i, 1) = itm.submatches(1)


Also One more Challenge I have here, If I want to extract text(abbreviation) as Criteria list what will be the code.
Similar task but Criteria is now Text


Column- A Input Data
Column - B Expected Output.
Column - D Criteria.


Below is Data Table,expected output and Criteria Column.

Book1 (version 2).xlsb
	A	B	C	D	E
1	Invoices	Product abbreviation		Product Abbreviation	Meaning
2	7350002095-17661-10-mos	MOS		mos	Mouse
3	7550001171 30 hed	HED		hed	headphone
4	5500001065-10-Pen-17642	Pen		Pen	Pendrive
5	5100001456-10Pen-10010	pen		RT	Router
6	5100001662-10Pen-9945	pen		h	Hard DISK
7	5100001577-35Pen-9831	pen		mt	Motherboard
8	6450000141-35-RT	RT		SR	Screen Guard
9	4300122304 - 20 - H	H		OTG	OTG Pendrive
10	5650000619/15334 F D	D		D	Desktop
11				KB	Keyboard
12	5010001010MT35	MT
13	5010000955mt10	MT
14	5010000016SR10	SR
15	5010001013OTG10	OTG
16	5010001014KB10/20	KB
Sheet2

Thanks
mg

 

[Peter_SSs]

Please can you comment below line to understand what it is doing.

RX.Pattern = "(^|\D)(\d\d)(?=\D|$)"

The pattern is
The start of the string in the cell (^) or (|) not a digit (\D)
Followed by two digits (\d\d)
Then look ahead to what comes next (?=) either a non-digit (\D) or (|) the end of the text ($)

Please can you comment below line to understand what it is doing.

If InStr(1, ProdCodes, "|" & itm.submatches(1) & "|") > 0 Then b(i, 1) = itm.submatches(1)

Look at each pair of digits found (the blue part above) in the list of product codes to see if it is there. All codes separated by "|" to ensure the exact code is found in case any product codes in column D had more than 2-digits

 

[Peter_SSs]

If I want to extract text(abbreviation) as Criteria list what will be the code.

Try

Sub Get_Product_Abbrev()
  Dim RX As Object
  Dim a As Variant, b As Variant
  Dim i As Long
  
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  RX.Pattern = "(^|[^a-z])(" & Join(Application.Transpose(Range("D2", Range("D" & Rows.Count).End(xlUp))), "|") & ")([^a-z]|$)"
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    If RX.Test(a(i, 1)) Then b(i, 1) = RX.Execute(a(i, 1))(0).submatches(1)
  Next i
  Range("B2").Resize(UBound(a)).Value = b
End Sub

 

[Mallesh23]

Hi Peter

Great !! This also worked as expected. ?

So we have seperated product code, product abbreviation.
Last question can you help me in extracting Full Account No using above same approach.

Column A is data
Column B is expected data.

Criteria to pick Full Account No is Column D. Account No should begin with specified digit. else blank

Below is a table with expected output and Criteria

Book1 (version 2).xlsb
	A	B	C	D
1	Invoices	Product abbreviation		Criteria Account Code
2	7350002095-17661-10-mos	7350002095		7350
3	P25125/6000000453 RW	6000000453		600
4	P/W/16566	16566		165
5	4500000535-10-P	4500000535		450
6	D-W-10983-3150004927	10983		109
7	FP-PR-#11746-311	11746		117
8	F-W-10713-3150004797	3150004797		315
9	refu25188/6000000502	25188		251
10	F-SID-10306-31500046	31500046		315
11
12	9618/475017300/RW/D	475017300		475
13	F-W-13158-3150004700	3150004700		315
Sheet2

Thanks
mg ?

 

[Peter_SSs]

Could there really be blank cells in the column D criteria list or did that only happen because you decided later to insert a blank row in your sample data?

 

[Peter_SSs]

Further question. I didn't notice that the values in column B match row-by-row the values in column D. Is that how it will work?
That is, would cell B2 below be blank because there is not a "109*" number in A2 or will B2 still be 7350002095 because 7350 is a prefix listed somewhere in column D?

Mallesh23 2020-08-13 1.xlsm
	A	B	C	D
1	Invoices	Product abbreviation		Criteria Account Code
2	7350002095-17661-10-mos			109
3				7350
Sheet5)

 

[Mallesh23]

Hi Peter,

OMG, , my mistake , Typo Error.
1) Criteria list is not row by row. bring output first Match as per Criteria list.
2) Reg 7350, usually account Criteria is 3 digit. if future change in Criteria list it should accomodate

Criteria will be Inner loop. assume there are no duplicates in account code, and always 3 digit. Thanks


Thanks
mg