Extract numerical data from a specific type of substrings

[vladimiratanasiu]

Hello!

I have a very large database of products. Each product is defined by a string, that includes information about its name (e.g. METRO CHEF MURATURI ASORTATE, MIRINDA STRUGURI SI PEPENE GALBEN etc. – see the red colored texts) and quantity. The quantity of the contents is defined by specific units of measure (UM - see black colored texts), depending on the type of product: weight – (kilo)grams – KG /G; volume – (mili)litre – ML /L; length – centimeters – CM; number of pieces / set - BUC. Some products are not allocated any UM (e.g. ORNAMENT MOS CRACIUN BARBA, CIOCAN LEMN PT CARNE). Most of products have the UM substrings data placed at the end of the string, but in some cases they are inserted in the middle of it (e.g. SOS USTUROI 420G UNIVER, CANA OPAL 250ML PARADISE). No name has the UM at the beginning of the string. I mention that all UM substrings have a maximum number of 4 digits, and are separated from the rest of string’s elements by space(s). Rarely, some values are expressed as decimal numbers with dots (e.g. MIRINDA STRUGURI SI PEPENE GALBEN 0.5L, ZAREA DACIC CIDRU AFINE 0.275L). I need to extract in another column the numerical data of UM substrings, defined on the basis of the above mentioned UMs. I wonder if the substrings could be defined as wildcards, built on the basis of UMs standard names. If the UM substring misses from a string, I would like result be blank or 0 in the destination cell.

Thank you!

P.S. I attached a screenshot too of the table , as the XL2BB couldn't import the original table formatted completly.

Book1.xlsx
	A	B
1	Initial data	Desired results
2	ORNAMENT MOS CRACIUN BARBA
3	METRO CHEF MURATURI ASORTATE 1600G	1600
4	MIRINDA STRUGURI SI PEPENE GALBEN 0.5L	0,5
5	MIRINDA STRUGURI/PEPENE GALBEN 2L	2
6	IAURT CAPRA AMILACT 340ML	340
7	COSMIN MUSLI 30% FRUCTE 250G	250
8	DR.O PRAF TORT GELLE FRUCTE PADURE 8G	8
9	CHIO POMBAR PIZZA 40G	40
10	GEL MAINI AMANTE 65ML	65
11	FORMA TEFLON CHEC 25CM ZENKER	25
12	TAVA CUPTOR OTI 38X26CM	38X26
13	MONODOZE CAFEA CAPSULE BAROCCO 50BUCATI	50
14	CIOCAN LEMN PT CARNE
15	APARATE RAS GILLETTE VENUS3 3BUCATI	3
16	ZAREA DACIC CIDRU AFINE 0.275L	0.275
17	GIANA ULEI TURTE MASLINE 1000ML	1000
18	SOS USTUROI 420G UNIVER	420
19	CANA OPAL 250ML PARADISE	250
Sheet1

 

[kvsrinivasamurthy]

From post #1
What about string like 38X26. Is it be extracted or not. If yes It should be 38X26 or 3826.

 

[vladimiratanasiu]

This is the result of previous macro, extracting your mentioned substring as I needed in my first message. As I said, it needs to be updated, but its incipient result is ok. Have a nice day / evening!

 

[rlv01]

Hello, rlv01! I tried to run the macro updated. Unfortunately, it generates the photo messages from below. I attached the full structure of database Fisier Migrare Materiale RETAIL.xlsm, containing more relevant products for testing. Please, verify it and tell me how could I solve this issue. Thank you!

That error means you have two copies of Function OnlyNumbers in your code

Function OnlyNumbers(S As String) As String
    Dim RX As Object

    Set RX = CreateObject("VBScript.RegExp")
    
    RX.Global = True
    RX.Pattern = "[^0-9]"
    
    OnlyNumbers = RX.Replace(S, "")
End Function

You only need one, so delete one of them.

With respect to your dropbox file, I cannot download unsecure files on the internet to this PC, so I am unable to look at it.

 

[vladimiratanasiu]

From post #1
What about string like 38X26. Is it be extracted or not. If yes It should be 38X26 or 3826.

That error means you have two copies of Function OnlyNumbers in your code

Function OnlyNumbers(S As String) As String
    Dim RX As Object

    Set RX = CreateObject("VBScript.RegExp")
  
    RX.Global = True
    RX.Pattern = "[^0-9]"
  
    OnlyNumbers = RX.Replace(S, "")
End Function

You only need one, so delete one of them.

With respect to your dropbox file, I cannot download unsecure files on the internet to this PC, so I am unable to look at it.

Hello, Rlv01! I used your last macro ad litteram, missing this module. I updated it and now errors are gone. However, when applying the macro neither column P (numerical quantities), nor the column Q (UMs) are populated with the necessary data. I attach a photo of the macro used in the file and please tell me what to do in order to solve this problem. Thank you!

 

[rlv01]

Hello, Rlv01! I used your last macro ad litteram, missing this module. I updated it and now errors are gone. However, when applying the macro neither column P (numerical quantities), nor the column Q (UMs) are populated with the necessary data. I attach a photo of the macro used in the file and please tell me what to do in order to solve this problem. Thank you!

The problem is that you moved your data to a different column than in your post #1. When data moves, the code must generally be adjusted.

Sub ExtractNumbers3()
    Dim WS As Worksheet
    Dim CellRange As Range
    Dim R As Range
    Dim I As Long
    Dim NS As String, S As String
    Dim SA As Variant
    Dim StartRow As Long, Ofs As Long
    Dim ResultsCol As String
    Dim DataCol As String

    Set WS = ActiveSheet

    With WS
        StartRow = 9                                  'row to start at
        DataCol = "I"                                 'column for data.
        ResultsCol = "P"                              'column for results.

        Ofs = .Columns(ResultsCol).Column - .Columns(DataCol).Column
        Set CellRange = .Range(DataCol & "1", .Range(DataCol & .Rows.Count).End(xlUp)).Offset(StartRow - 1)
        With CellRange
            Set CellRange = .Resize(.Count - (StartRow - 1))
        End With
    End With

    For Each R In CellRange
        SA = Split(Application.Trim(Replace(R.Value, Chr(9), " ")))
        For I = UBound(SA) To 0 Step -1
            NS = OnlyNumbers(CStr(SA(I)))
            If NS <> "" Then
                NS = SA(I)
                S = CStr(SA(I))
                Do While Not IsNumeric(Right(NS, 1))
                    NS = Left(NS, Len(NS) - 1)
                Loop
                R.Offset(0, Ofs).Value = NS
                S = Mid(S, Len(NS) + 1, Len(S))
                If Len(S) <= 4 Then
                    R.Offset(0, Ofs + 1).Value = S
                Else
                    R.Offset(0, Ofs + 1).Value = ""
                End If
                Exit For
            Else
                R.Offset(0, Ofs).Value = ""
                R.Offset(0, Ofs + 1).Value = ""
            End If
        Next I
    Next R
End Sub

Results:

Book2
	A								I							P	Q	R
1									MAKTX							BRGEW	GEWEI
2									Date de baza 1							Date de baza 1	Date de baza 1
3									Descriere material lb romana							Greutate brută	Unitate de greutate
4									CHAR							QUAN	UNIT
5									40							17	3
6									denumirea produsului in 40 caractere							greutatea bruta
7	1								LEGUME-FRUCTE PRET REDUS 0.4
8	2								ARDEI IUTE GALBEN KG
9	3								BOROMIR CHEC MARMORAT CIOCOLATA/ALUNE 400G							400	G
10	4								FOX SALAM RUSTIC GASTRO KG
11	7								JUCARIE MASINA FARMER TRUCK
12	11								JUCARIE SET ANIMALE
13	12								ORNAMENT MOS CRACIUN BARBA
14	13								METRO CHEF MURATURI ASORTATE 1600G							1600	G
15	14								MIRINDA STRUGURI SI PEPENE GALBEN 0.5L							0.5	L
16	15								MIRINDA STRUGURI/PEPENE GALBEN 2L							2	L
17	16								LIPTON ICE TEA GREEN WHITE PIERSICA 1.5L							1.5	L
18	17								IAURT CAPRA AMILACT 340ML							340	ML
Sheet7

 

[vladimiratanasiu]

The problem is that you moved your data to a different column than in your post #1. When data moves, the code must generally be adjusted.

Sub ExtractNumbers3()
    Dim WS As Worksheet
    Dim CellRange As Range
    Dim R As Range
    Dim I As Long
    Dim NS As String, S As String
    Dim SA As Variant
    Dim StartRow As Long, Ofs As Long
    Dim ResultsCol As String
    Dim DataCol As String

    Set WS = ActiveSheet

    With WS
        StartRow = 9                                  'row to start at
        DataCol = "I"                                 'column for data.
        ResultsCol = "P"                              'column for results.

        Ofs = .Columns(ResultsCol).Column - .Columns(DataCol).Column
        Set CellRange = .Range(DataCol & "1", .Range(DataCol & .Rows.Count).End(xlUp)).Offset(StartRow - 1)
        With CellRange
            Set CellRange = .Resize(.Count - (StartRow - 1))
        End With
    End With

    For Each R In CellRange
        SA = Split(Application.Trim(Replace(R.Value, Chr(9), " ")))
        For I = UBound(SA) To 0 Step -1
            NS = OnlyNumbers(CStr(SA(I)))
            If NS <> "" Then
                NS = SA(I)
                S = CStr(SA(I))
                Do While Not IsNumeric(Right(NS, 1))
                    NS = Left(NS, Len(NS) - 1)
                Loop
                R.Offset(0, Ofs).Value = NS
                S = Mid(S, Len(NS) + 1, Len(S))
                If Len(S) <= 4 Then
                    R.Offset(0, Ofs + 1).Value = S
                Else
                    R.Offset(0, Ofs + 1).Value = ""
                End If
                Exit For
            Else
                R.Offset(0, Ofs).Value = ""
                R.Offset(0, Ofs + 1).Value = ""
            End If
        Next I
    Next R
End Sub

Results:

Book2
	A								I							P	Q	R
1									MAKTX							BRGEW	GEWEI
2									Date de baza 1							Date de baza 1	Date de baza 1
3									Descriere material lb romana							Greutate brută	Unitate de greutate
4									CHAR							QUAN	UNIT
5									40							17	3
6									denumirea produsului in 40 caractere							greutatea bruta
7	1								LEGUME-FRUCTE PRET REDUS 0.4
8	2								ARDEI IUTE GALBEN KG
9	3								BOROMIR CHEC MARMORAT CIOCOLATA/ALUNE 400G							400	G
10	4								FOX SALAM RUSTIC GASTRO KG
11	7								JUCARIE MASINA FARMER TRUCK
12	11								JUCARIE SET ANIMALE
13	12								ORNAMENT MOS CRACIUN BARBA
14	13								METRO CHEF MURATURI ASORTATE 1600G							1600	G
15	14								MIRINDA STRUGURI SI PEPENE GALBEN 0.5L							0.5	L
16	15								MIRINDA STRUGURI/PEPENE GALBEN 2L							2	L
17	16								LIPTON ICE TEA GREEN WHITE PIERSICA 1.5L							1.5	L
18	17								IAURT CAPRA AMILACT 340ML							340	ML
Sheet7

Thank you very much, Rlv01! It works perfectly, you are brilliant!