vba for complex splitting text & numbers according to description

RAM72 · Jun 22, 2016

Hi All

First I d'ont if this is achievable in VBA.

I have list of products particularly drinks, syrup , alcoholic products etc.

The issue ,I need to break down the packaging, the litres,centlitres ,% of alcohol to their respective headers according to the product description which is not standard .

.

The list represents all the combinations of product description which daily represent 8000 rows of data

. and the need to this manually

See attached , yellow represents the expected results per column headers

If any one can help to solve this complex puzzle

Marc L · Jun 23, 2016

Hi !

According to your attachment for values with unit only :

Code:

Sub Demo1()
    Dim BT() As Byte, C%, N&, R&, S$
    VC = [{88,67,76,68}]
    VA = Cells(1).CurrentRegion.Columns(1).Value
    ReDim VT(2 To UBound(VA), 1 To 4)
For R& = 2 To UBound(VA)
       BT = StrConv(VA(R, 1), vbFromUnicode)
    For N = UBound(BT) To 0 Step -1
        Select Case BT(N)
            Case 46
                If C * N Then
                    Select Case BT(N - 1)
                           Case 48 To 57:  S = "." & S
                    End Select
                End If
            Case 48 To 57
                If C Then
                    S = Chr$(BT(N)) & S
                ElseIf N Then
                    If BT(N - 1) = 76 Then S = "." & Chr$(BT(N))
                End If
            Case 67, 68, 76, 88
                    If C And S > "" And S <> "%" Then VT(R, C) = Evaluate(S): S = ""
                If N Then
                    C = Application.Match(BT(N), VC, 0)
                    If VT(R, C) Then C = 0 Else If C = 4 Then S = "%"
                End If
            Case Else
                If C And Not (BT(N) = 32 And S = "") Then
                    If S > "" And S <> "%" Then VT(R, C) = Evaluate(S)
                    C = 0:  S = ""
                End If
        End Select
    Next
Next
    [B2:E2].Resize(UBound(VT) - 1).Value = VT
End Sub

Do you like it ? So thanks to click on bottom right Like !

RAM72 · Jun 23, 2016

Marc L said:

Hi !

According to your attachment for values with unit only :

Code:

Sub Demo1()
    Dim BT() As Byte, C%, N&, R&, S$
    VC = [{88,67,76,68}]
    VA = Cells(1).CurrentRegion.Columns(1).Value
    ReDim VT(2 To UBound(VA), 1 To 4)
For R& = 2 To UBound(VA)
       BT = StrConv(VA(R, 1), vbFromUnicode)
    For N = UBound(BT) To 0 Step -1
        Select Case BT(N)
            Case 46
                If C * N Then
                    Select Case BT(N - 1)
                           Case 48 To 57:  S = "." & S
                    End Select
                End If
            Case 48 To 57
                If C Then
                    S = Chr$(BT(N)) & S
                ElseIf N Then
                    If BT(N - 1) = 76 Then S = "." & Chr$(BT(N))
                End If
            Case 67, 68, 76, 88
                    If C And S > "" And S <> "%" Then VT(R, C) = Evaluate(S): S = ""
                If N Then
                    C = Application.Match(BT(N), VC, 0)
                    If VT(R, C) Then C = 0 Else If C = 4 Then S = "%"
                End If
            Case Else
                If C And Not (BT(N) = 32 And S = "") Then
                    If S > "" And S <> "%" Then VT(R, C) = Evaluate(S)
                    C = 0:  S = ""
                End If
        End Select
    Next
Next
    [B2:E2].Resize(UBound(VT) - 1).Value = VT
End Sub

Do you like it ? So thanks to click on bottom right Like !

Hi Marc

I never thought this could be possible in vba,this code is

as it saves me from a daily tedious task.

But as per screen shot , what need to be changed in the code when columns ranges changes that is from column L to P as example.
If possible can you explain me in quotes how the code works.

Thank you again for assistance

NARAYANK991 · Jun 23, 2016

Hi ,

Please check the results in rows 8 , 27 and 30.

Narayan

Marc L · Jun 23, 2016

If range columns are not the same as attachment,
you must update codelines #4 (source) & #36 (destination).

The code scans from last character of a cell to its first one
as you can see by progressing in code with step by step mode (F8 key)
and looking at Locals window …

Marc L · Jun 23, 2016

With this easier to understand - I hope - new demonstration
values without unit at end of cells are saved to CL column :

Code:

Sub Demo2()
    Dim B$, C%, L&, N&, R&, S$
    VC = [{"X","C","L","D"}]
    VA = [A1].CurrentRegion.Columns(1).Value
    ReDim VT(2 To UBound(VA), 1 To 4)
For R& = 2 To UBound(VA)
        L = Len(VA(R, 1))
    For N = 1 To L
                    B = Mid$(VA(R, 1), N, 1)
        Select Case B
        Case "."
            If S > "" Then S = S & B
        Case "0" To "9"
            S = S & B
            If N = L Then VT(R, C - (C = 0) * 2) = Val(S): C = 0: S = ""
        Case "C", "D", "L", "X"
            If S > "" Then
                If B = "L" And N < L Then
                                B = Mid$(VA(R, 1), N + 1, 1)
                    Select Case B
                    Case "0" To "9"
                        C = 3
                        S = S & "." & B
                        N = N + 1
                        If N = L Then VT(R, 3) = Val(S): C = 0: S = ""
                    Case Else
                        VT(R, 3) = Val(S):  S = ""
                    End Select
                Else
                       C = Application.Match(B, VC, 0)
                VT(R, C) = Val(S) / 10 ^ (-(C = 4) * 2)
                       C = 0
                       S = ""
                End If
            End If
        Case Else
            If S > "" Then
                If B = " " Then
                    If C Or N = L Then VT(R, C - (C = 0) * 2) = Val(S): C = 0: S = ""
                Else
                    S = ""
                End If
            End If
        End Select
    Next
Next
    [B2:E2].Resize(UBound(VT) - 1).Value = VT
End Sub

You should Like it !

RAM72 · Jun 23, 2016

Marc L said:

With this easier to understand - I hope - new demonstration
values without unit at end of cells are saved to CL column :

Code:

Sub Demo2()
    Dim B$, C%, L&, N&, R&, S$
    VC = [{"X","C","L","D"}]
    VA = [A1].CurrentRegion.Columns(1).Value
    ReDim VT(2 To UBound(VA), 1 To 4)
For R& = 2 To UBound(VA)
        L = Len(VA(R, 1))
    For N = 1 To L
                    B = Mid$(VA(R, 1), N, 1)
        Select Case B
        Case "."
            If S > "" Then S = S & B
        Case "0" To "9"
            S = S & B
            If N = L Then VT(R, C - (C = 0) * 2) = Val(S): C = 0: S = ""
        Case "C", "D", "L", "X"
            If S > "" Then
                If B = "L" And N < L Then
                                B = Mid$(VA(R, 1), N + 1, 1)
                    Select Case B
                    Case "0" To "9"
                        C = 3
                        S = S & "." & B
                        N = N + 1
                        If N = L Then VT(R, 3) = Val(S): C = 0: S = ""
                    Case Else
                        VT(R, 3) = Val(S):  S = ""
                    End Select
                Else
                       C = Application.Match(B, VC, 0)
                VT(R, C) = Val(S) / 10 ^ (-(C = 4) * 2)
                       C = 0
                       S = ""
                End If
            End If
        Case Else
            If S > "" Then
                If B = " " Then
                    If C Or N = L Then VT(R, C - (C = 0) * 2) = Val(S): C = 0: S = ""
                Else
                    S = ""
                End If
            End If
        End Select
    Next
Next
    [B2:E2].Resize(UBound(VT) - 1).Value = VT
End Sub

You should Like it !

Working ,but I forgotten to attach the screenshot from previous post , but sorry I am still confused
Advise as per screenshot where to modify the codes as per the ranges from column L TO P.

Thanks

Could you

Chihiro · Jun 23, 2016

Change...

Code:

VA = [A1].CurrentRegion.Columns(1).Value

To

Code:

VA = [A1].CurrentRegion.Columns(12).Value

I.E. Change from Column #1 (A) to Column #12 (L)

Then change

Code:

[B2:E2].Resize(UBound(VT) - 1).Value = VT

To

Code:

[M2:P2].Resize(UBound(VT) - 1).Value = VT

jindon · Jun 24, 2016

Code:

Sub test()
    Dim a, i As Long, temp As String, m As Object
    With Cells(1).CurrentRegion.Columns("l:p")
        .Offset(1, 1).ClearContents
        a = .Value
        With CreateObject("VBScript.RegExp")
            .Global = True
            For i = 2 To UBound(a, 1)
                temp = a(i, 1)
                .Pattern = "\d+(?=X)"
                If .test(temp) Then a(i, 2) = .Execute(temp)(0): temp = .Replace(temp, "")
                .Pattern = "(.*)(\d+)L(\d+)(.*)"
                If .test(temp) Then a(i, 4) = .Replace(temp, "$2.$3"): temp = .Replace(temp, "$1$4")
                .Pattern = "(\d+(\.\d+)?)( *CL|$)"
                If .test(temp) Then
                    Set m = .Execute(temp)(0)
                    If (m Like "*CL") + (m Like "*C") + (IsNumeric(m)) Then
                        a(i, 3) = m.submatches(0)
                    Else
                        a(i, 4) = m.submatches(0)
                    End If
                End If
                .Pattern = "\d+(?=D)"
                If .test(temp) Then a(i, 5) = .Execute(temp)(0) & "%"
                .Pattern = "\d+(?= *L)"
                If .test(temp) Then a(i, 4) = .Execute(temp)(0)
            Next
        End With
        .Value = a
    End With
End Sub

Marc L · Jun 24, 2016

Hi jindon !

Issues :
• row #8 : value in L column instead of CL column …
(optional as there is no unit for the value)

• Row #13 : column CL remains empty instead of 75 …

jindon · Jun 24, 2016

1) No idea about row#8, it is identical to the original result.

2) 3rd pattern

Code:

.Pattern = "(\d+(\.\d+)?)( *CL|$)

to

Code:

.Pattern = "(\d+(\.\d+)?)( *CL*|$)

Marc L · Jun 24, 2016

No more issue on row #13 with new third pattern …

Marc L · Jun 24, 2016

Row #8 issue :

jindon · Jun 24, 2016

Don't understand what you are trying to say.

Marc L · Jun 24, 2016

I got the same issue with your workbook, I'm under Seven,
maybe it's my local version of RegExp ActiveX …

But it's not a big concern as I'm not the OP, let's wait if it's Ok for RAM72 …

RAM72 · Jun 24, 2016

Marc, Jindon,Chihiro
Thanks you all for your support .

First for Chihiro when amended Marc subdemo2, it worked but I have a drackback when I added a second range in blue it did not worked!!

but when applying demo 2 in range Columns A when added additional data in column A in blue it worked

.

Jindon test sheet when testing column L , worked but additional data in blue

, did not worked why I d'ont know.

But Jindon test1column when applying no issue when adding additional data in blue

column A

For Marc sub demo2 in column A no issue worked even adding data in blue

Thus the issue is when adding additional data in blue both Marc and Jindon code
did not work when I add additional data blue in column L. but column A it worked whe additional data in blue was added .

Could look you look in

See attached all sub shows the name of the sheet for ease of understanding

Marc L · Jun 24, 2016

Chihiro tried but was blind without real data
like I was in your previous thread where I yet mentioned this need …

As I yet wrote, you must update source and destination ranges.
Difficulty level : very begginner, any 10 years old kid can do it !

• Demo2 source range is in codeline #4 :

VA = [A1].CurrentRegion.Columns(1).Value

So if A1 is no more the first cell, why don't you update this codeline
according to your real data ?!

• Demo 2 destination range is in codeline #47 :

[B2:E2].Resize(UBound(VT) - 1).Value = VT

So if B2:E2 is no more the destination first row, why don't you update
this codeline according to your real data ?!

Again, it's a waste of time to not join data respecting real layout ‼
We work on attachment, so if you are not able to mod easy things …

jindon · Jun 24, 2016

RAM72 said:
Jindon test sheet when testing column L , worked but additional data in blue, did not worked why I d'ont know.

But Jindon test1column when applying no issue when adding additional data in blue column A

Just add data in col.L, not col.A.

vba for complex splitting text & numbers according to description

Member

Attachments

Excel Ninja

Member

Excel Ninja

Excel Ninja

Excel Ninja

Member

Attachments

Excel Ninja

Well-Known Member

Excel Ninja

Well-Known Member

Excel Ninja

Excel Ninja

Well-Known Member

Attachments

Excel Ninja

Member

Attachments

Excel Ninja

Well-Known Member