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

 

[rlv01]

Maybe something like this.

Sub ExtractNumbers()
    Dim WS As Worksheet
    Dim CellRange As Range
    Dim R As Range
    Dim I As Long
    Dim NS As String
    Dim SA As Variant

    Set WS = ActiveSheet

    With WS
        Set CellRange = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
    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
                R.Offset(0, 1).Value = NS
                If InStr(SA(I), ".") > 0 Or InStr(SA(I), ",") > 0 Or InStr(SA(I), "X") > 0 Then
                    NS = SA(I)
                    Do While Not IsNumeric(Right(NS, 1))
                        NS = Left(NS, Len(NS) - 1)
                    Loop
                    R.Offset(0, 1).Value = NS
                End If
                Exit For
            Else
                R.Offset(0, 1).Value = ""
            End If
        Next I
    Next R
End Sub


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

 

[vladimiratanasiu]

Maybe something like this.

Sub ExtractNumbers()
    Dim WS As Worksheet
    Dim CellRange As Range
    Dim R As Range
    Dim I As Long
    Dim NS As String
    Dim SA As Variant

    Set WS = ActiveSheet

    With WS
        Set CellRange = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
    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
                R.Offset(0, 1).Value = NS
                If InStr(SA(I), ".") > 0 Or InStr(SA(I), ",") > 0 Or InStr(SA(I), "X") > 0 Then
                    NS = SA(I)
                    Do While Not IsNumeric(Right(NS, 1))
                        NS = Left(NS, Len(NS) - 1)
                    Loop
                    R.Offset(0, 1).Value = NS
                End If
                Exit For
            Else
                R.Offset(0, 1).Value = ""
            End If
        Next I
    Next R
End Sub


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

Thank you

Maybe something like this.

Sub ExtractNumbers()
    Dim WS As Worksheet
    Dim CellRange As Range
    Dim R As Range
    Dim I As Long
    Dim NS As String
    Dim SA As Variant

    Set WS = ActiveSheet

    With WS
        Set CellRange = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
    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
                R.Offset(0, 1).Value = NS
                If InStr(SA(I), ".") > 0 Or InStr(SA(I), ",") > 0 Or InStr(SA(I), "X") > 0 Then
                    NS = SA(I)
                    Do While Not IsNumeric(Right(NS, 1))
                        NS = Left(NS, Len(NS) - 1)
                    Loop
                    R.Offset(0, 1).Value = NS
                End If
                Exit For
            Else
                R.Offset(0, 1).Value = ""
            End If
        Next I
    Next R
End Sub


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

Thank you very much, Rlv01! Your macro works perfectly in my previous example. Considering my real database, I think they are still necessary some changes within the macro and I don't know how to make them. As it's seen, in my real table the source of products data is placed in column I, starting from cell I7 to about I15000. Similarly, the target / destination range of numerical values extracted is column P, keeping the same structure. At the same time, the column Q requires data about UMs name / acronym. In this sense, I ask you politely if is any way to extract in every cell of column Q, similarly to the column P, the UM name from corresponding substrings of column I (see the yellow coloures cells).

Thank you!

Book1
	A								I							P	Q
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								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							500	ML
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
Sheet1

 

[rlv01]

Sub ExtractNumbers2()
    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

    Set WS = ActiveSheet

    With WS
        Set CellRange = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
    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, 1).Value = NS
                S = Mid(S, Len(NS) + 1, Len(S))
                If Len(S) <= 4 Then
                    R.Offset(0, 2).Value = S
                Else
                    R.Offset(0, 2).Value = ""
                End If
                Exit For
            Else
                R.Offset(0, 1).Value = ""
                R.Offset(0, 2).Value = ""
            End If
        Next I
    Next R
End Sub

 

[vladimiratanasiu]

Sub ExtractNumbers2()
    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

    Set WS = ActiveSheet

    With WS
        Set CellRange = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
    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, 1).Value = NS
                S = Mid(S, Len(NS) + 1, Len(S))
                If Len(S) <= 4 Then
                    R.Offset(0, 2).Value = S
                Else
                    R.Offset(0, 2).Value = ""
                End If
                Exit For
            Else
                R.Offset(0, 1).Value = ""
                R.Offset(0, 2).Value = ""
            End If
        Next I
    Next R
End Sub

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!

 

[kvsrinivasamurthy]

In B3 enter 1600
Select B4
Data--> (in Data tools) click Flash Fill.
In column B you get required result.

 

[vladimiratanasiu]

In B3 enter 1600
Select B4
Data--> (in Data tools) click Flash Fill.
In column B you get required result.

Hello, kvsrinivasamurthy! I tested before your option too, but it is not the proper one for my issue. I need only numerical results from specific substrings and it gives many errors like the yellow coloured ones. Please, analyze all content of this topic, and if you find / know another efficient solution I'm very glad for your support. Thank you!

 

[kvsrinivasamurthy]

I am getting only numerical values.

 

[kvsrinivasamurthy]

Do not enter BARBA in B2.
Enter 1600 in B3. select B4 then click Flash Fill.

 

[vladimiratanasiu]

Do not enter BARBA in B2.
Enter 1600 in B3. select B4 then click Flash Fill.

If you read all posts, it's mentioned that the database include names of products as strings. Plenty of them have alpha numerical substrings, other miss the numerical part. The previous macro needs some adjustments, but basically it covers the necessary conditions. If you search for an efficient solution, please take into account all data posted before. Thank you!