Segmenting text contained in one cell according to the titles there contained.

[Noodles90]

Hi, I am new in the ways of VBA coding, and I have been mostly adapting recorded code. The most that I can do is to define variables, make relative references and simple loops xD
I am working with catalogs for cars and car parts. For one particular distributor, the only way of obtaining the full specs from the system is all altogether.
In this way, we need to separate the text manually, and this process is a quite time-consuming process (The texts are way longer than what is presented in the example).

Example 1, (let's say this text is pasted in cell A1):

Engine size - Displacement - Engine capacity: 999 cm3 or 61 cu-in Body: SUV / TT Num. of Doors: 5 Wheelbase: 267.4 cm or 105.28 inches Length: 434.1 cm or 170.91 inches Width: 180.4 cm or 71.02 inches Height: 169.3 cm or 66.65 inches Front Axle 156.3 cm or 61.54 inches Rear Axle 157 cm or 61.81 inches Ground clearance: 21.0 cm / 8.27 inches Ground clearance: 21.0 cm / 8.27 inches Max. Towing Capacity Weight 1400 Kg or 3086.47 lbs

Final result for Example 1:

Cell	Title	Text
A2	Engine size - Displacement - Engine capacity:	999 cm3 or 61 cu-in
A3	Body: SUV / TT Num. of Doors:	5​
A4	Wheelbase:	267.4 cm or 105.28 inches
A5	Length:	434.1 cm or 170.91 inches
A6	Width:	180.4 cm or 71.02 inches
A7	Height:	169.3 cm or 66.65 inches
A8	Front Axle	156.3 cm or 61.54 inches
A9	Rear Axle	157 cm or 61.81 inches
A10	Ground clearance:	21.0 cm / 8.27 inches
A11	Ground clearance:	21.0 cm / 8.27 inches
A12	Max. Towing Capacity Weight	1400 Kg or 3086.47 lbs

Now the tricky part is that there is no marker distinguishing the titles from the text, some have ":" at the end, some not...
Also, although the titles appear always in the same order, if there is no information regarding one of these, it simply does not appear in the text.

Example 2 (Equal to example 1, but with no Front Axle information):

Engine size - Displacement - Engine capacity: 999 cm3 or 61 cu-in Body: SUV / TT Num. of Doors: 5 Wheelbase: 267.4 cm or 105.28 inches Length: 434.1 cm or 170.91 inches Width: 180.4 cm or 71.02 inches Height: 169.3 cm or 66.65 inches Rear Axle 157 cm or 61.81 inches Ground clearance: 21.0 cm / 8.27 inches Ground clearance: 21.0 cm / 8.27 inches Max. Towing Capacity Weight 1400 Kg or 3086.47 lbs

As there are no markers for the titles, I am thinking that the best is to set the titles as constants.
This way if more titles are introduced into the system, I can simply add them to the code, and add a number to the Integer:

Code start example:

Dim Const Title1 = "Engine size - Displacement - Engine capacity:"
Dim Const Title2 = "Body: SUV / TT Num. of Doors:"
Dim Const Title3 = "Wheelbase:"

Dim x As Integer
For x = 1 To 3

Having these constants defined, it would be possible to do the following:
Step 1 -Search for the first title in the code; If not found, search for title2; If found, paste it in the cell below;
Step 2 -Search for the following title; if found, paste the text contained between the first found title and the second found title, one cell down, one cell to the left; If not found, search the next title;
Step3 - Loop

And repeating this process untill all titles present in the original cell are separated below:

	A	B
1​	Engine size - Displacement - Engine capacity: 999 cm3 or 61 cu-in Body: SUV / TT Num. of Doors: 5 Wheelbase: 267.4 cm or 105.28 inches Length: 434.1 cm or 170.91 inches Width: 180.4 cm or 71.02 inches Height: 169.3 cm or 66.65 inches Front Axle 156.3 cm or 61.54 inches Rear Axle 157 cm or 61.81 inches Ground clearance: 21.0 cm / 8.27 inches Ground clearance: 21.0 cm / 8.27 inches Max. Towing Capacity Weight 1400 Kg or 3086.47 lbs
2​	Engine size - Displacement - Engine capacity:	999 cm3 or 61 cu-in
3​	Body: SUV / TT Num. of Doors:	5​
4​	Wheelbase:	267.4 cm or 105.28 inches
5​	Length:	434.1 cm or 170.91 inches
6​	Width:	180.4 cm or 71.02 inches
7​	Height:	169.3 cm or 66.65 inches
8​	Front Axle	156.3 cm or 61.54 inches
9​	Rear Axle	157 cm or 61.81 inches
10​	Ground clearance:	21.0 cm / 8.27 inches
11​	Ground clearance:	21.0 cm / 8.27 inches
12​	Max. Towing Capacity Weight	1400 Kg or 3086.47 lbs

My question is if this is possible, or if there is a better way of doing it, I am searching for ideas.
Can someone advise if I am thinking well here?

 

[Zot]

Try this. However, you need to tweak the code if you want to loop through data and to place result on different location.

Current code is for your sample

Option Compare Text
Sub GetSpec()

Dim strData As String, ArryTitle(10) As String
Dim n As Long, m As Long
Dim RegEx As Object, Matches As Object
Dim ws As Worksheet

ArryTitle(0) = "Engine size - Displacement"
ArryTitle(1) = "Body: SUV / TT Num. of Doors"
ArryTitle(2) = "Wheelbase"
ArryTitle(3) = "Length"
ArryTitle(4) = "Width"
ArryTitle(5) = "Height"
ArryTitle(6) = "Front Axl"
ArryTitle(7) = "Rear Axl"
ArryTitle(8) = "Ground clearance"
ArryTitle(9) = "Ground clearance"
ArryTitle(10) = "Max. Towing Capacity Weight"

Set RegEx = CreateObject("VBScript.RegExp")

Set ws = ActiveWorkbook.Sheets("Sheet1")
With RegEx
    .IgnoreCase = True
    .Global = True
End With

strData = ws.Range("A1")

m = 0
For n = 0 To 10
    Select Case n
        Case 0
            RegEx.Pattern = "\s\d{1,4}\.?\d{0,2} cm3 or \d{1,4} cu-in"
            Set Matches = RegEx.Execute(strData)
            ws.Range("B" & n + 2) = Matches(0)
        Case 1
            RegEx.Pattern = "Body: SUV / TT Num. of Doors: \d"
            Set Matches = RegEx.Execute(strData)
            ws.Range("B" & n + 2) = Right(Matches(0), 1)
        Case 2 To 9
            RegEx.Pattern = "\s\d{1,4}\.?\d{0,2} cm (or|/) \d{1,4}\.?\d{0,2} inches"
            Set Matches = RegEx.Execute(strData)
            If InStr(strData, ArryTitle(n)) > 0 Then
                ws.Range("B" & n + 2) = Matches(n - 2 - m)
            Else
                m = m + 1
            End If
        Case 10
            RegEx.Pattern = "\s\d{1,4}\.?\d{0,2} cm (or|/) \d{1,4}\.?\d{0,2} inches"
            Set Matches = RegEx.Execute(strData)
            ws.Range("B" & n + 2) = Matches(0)
    End Select
Next
               
End Sub

 

[Akuini]

If you have the list of all titles then you can put it in a sheet not as constants as you suggested.
I put the list in sheet2 col A. I assume the titles always in the same order.

Sub Noodles90()
Dim i As Long
Dim tx As String
Dim va, ary
Dim d As Object

With Sheets("Sheet2")
    va = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With

tx = Range("A1")
Set d = CreateObject("scripting.dictionary"): d.CompareMode = vbTextCompare

    For Each x In va
        If InStr(1, tx, x, vbTextCompare) Then
            d(x) = Empty
            tx = Replace(tx, x, "~", 1, 1, vbTextCompare)
        End If
    Next
Range("A2").Resize(d.Count, 1) = Application.Transpose(Array(d.Keys))
ary = Application.Transpose(Split(Mid(tx, 2), "~"))
Range("B2").Resize(UBound(ary), 1) = ary

End Sub

Here's an example: Example 2 (Equal to example 1, but with no Front Axle information):

Noodles90.xlsm
	A	B
1	Engine size - Displacement - Engine capacity: 999 cm3 or 61 cu-in Body: SUV / TT Num. of Doors: 5 Wheelbase: 267.4 cm or 105.28 inches Length: 434.1 cm or 170.91 inches Width: 180.4 cm or 71.02 inches Height: 169.3 cm or 66.65 inches Rear Axle 157 cm or 61.81 inches Ground clearance: 21.0 cm / 8.27 inches Ground clearance: 21.0 cm / 8.27 inches Max. Towing Capacity Weight 1400 Kg or 3086.47 lbs
2	Engine size - Displacement - Engine capacity:	999 cm3 or 61 cu-in
3	Body: SUV / TT Num. of Doors:	5
4	Wheelbase:	267.4 cm or 105.28 inches
5	Length:	434.1 cm or 170.91 inches
6	Width:	180.4 cm or 71.02 inches
7	Height:	169.3 cm or 66.65 inches
8	Rear Axle	157 cm or 61.81 inches
9	Ground clearance:	21.0 cm / 8.27 inches
10	Max. Towing Capacity Weight	21.0 cm / 8.27 inches
11		1400 Kg or 3086.47 lbs
Sheet1

The list:

Noodles90.xlsm
	A
1	TITLE
2	Engine size - Displacement - Engine capacity:
3	Body: SUV / TT Num. of Doors:
4	Wheelbase:
5	Length:
6	Width:
7	Height:
8	Front Axle
9	Rear Axle
10	Ground clearance:
11	Ground clearance:
12	Max. Towing Capacity Weight
Sheet2

 

[Peter_SSs]

Welcome to the MrExcel board!

.. and my version.

Sub SplitEmUP()
  Dim RX As Object
  Dim a As Variant, b As Variant, itm
  Dim i As Long, j As Long, k As Long, MaxRws As Long, MaxCols As Long
 
  ReDim b(1 To Rows.Count, 1 To 2)
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = "\s*(Engine size - Displacement - Engine capacity:|" & _
                "Body: SUV / TT Num. of Doors:|" & _
                "Wheelbase:|" & _
                "Length:|" & _
                "Width:|" & _
                "Height:|" & _
                "Front Axle|" & _
                "Rear Axle|" & _
                "Ground clearance:|" & _
                "Max. Towing Capacity Weight)\s*"
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value2
  For i = 1 To UBound(a)
    j = 0
    k = k + 2
    If k > MaxCols Then
      MaxCols = k
      ReDim Preserve b(1 To UBound(b), 1 To MaxCols)
    End If
    For Each itm In Split(Mid(RX.Replace(a(i, 1), "#$1@"), 2), "#")
      j = j + 1
      b(j, k - 1) = Split(itm, "@")(0): b(j, k) = Split(itm, "@")(1)
    Next itm
    If j > MaxRws Then MaxRws = j
  Next i
  Application.ScreenUpdating = False
  With Range("C2").Resize(MaxRws, MaxCols)
    .Value = b
    .Columns.AutoFit
  End With
  Application.ScreenUpdating = True
End Sub

My sample data in col A and results in col C, D, E, ...

Noodles90.xlsm
	A	B	C	D	E	F
1
2	Engine size - Displacement - Engine capacity: 999 cm3 or 61 cu-in Body: SUV / TT Num. of Doors: 5 Wheelbase: 267.4 cm or 105.28 inches Length: 434.1 cm or 170.91 inches Width: 180.4 cm or 71.02 inches Height: 169.3 cm or 66.65 inches Front Axle 156.3 cm or 61.54 inches Rear Axle 157 cm or 61.81 inches Ground clearance: 21.0 cm / 8.27 inches Ground clearance: 21.0 cm / 8.27 inches Max. Towing Capacity Weight 1400 Kg or 3086.47 lbs		Engine size - Displacement - Engine capacity:	999 cm3 or 61 cu-in	Engine size - Displacement - Engine capacity:	999 cm3 or 61 cu-in
3	Engine size - Displacement - Engine capacity: 999 cm3 or 61 cu-in Body: SUV / TT Num. of Doors: 5 Wheelbase: 267.4 cm or 105.28 inches Length: 434.1 cm or 170.91 inches Width: 180.4 cm or 71.02 inches Height: 169.3 cm or 66.65 inches Rear Axle 157 cm or 61.81 inches Ground clearance: 21.0 cm / 8.27 inches Ground clearance: 21.0 cm / 8.27 inches Max. Towing Capacity Weight 1400 Kg or 3086.47 lbs		Body: SUV / TT Num. of Doors:	5	Body: SUV / TT Num. of Doors:	5
4			Wheelbase:	267.4 cm or 105.28 inches	Wheelbase:	267.4 cm or 105.28 inches
5			Length:	434.1 cm or 170.91 inches	Length:	434.1 cm or 170.91 inches
6			Width:	180.4 cm or 71.02 inches	Width:	180.4 cm or 71.02 inches
7			Height:	169.3 cm or 66.65 inches	Height:	169.3 cm or 66.65 inches
8			Front Axle	156.3 cm or 61.54 inches	Rear Axle	157 cm or 61.81 inches
9			Rear Axle	157 cm or 61.81 inches	Ground clearance:	21.0 cm / 8.27 inches
10			Ground clearance:	21.0 cm / 8.27 inches	Ground clearance:	21.0 cm / 8.27 inches
11			Ground clearance:	21.0 cm / 8.27 inches	Max. Towing Capacity Weight	1400 Kg or 3086.47 lbs
12			Max. Towing Capacity Weight	1400 Kg or 3086.47 lbs
13
Sheet1

 

[Akuini]

Sorry, I just realized that a title can have more than one occurrence (e.g "Ground clearance:").
So use this one:

Sub Noodles90a()
Dim i As Long
Dim tx As String
Dim va, ary
Dim scA As Object

With Sheets("Sheet2")
    va = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With

tx = Range("A1")
Set scA = CreateObject("System.Collections.ArrayList")
    
    For Each x In va
        If InStr(1, tx, x, vbTextCompare) Then
            Do
            scA.Add x
            tx = Replace(tx, x, "~", 1, 1, vbTextCompare)
            Loop While InStr(1, tx, x, vbTextCompare)
        End If
    Next
Range("A2").Resize(scA.Count, 1) = Application.Transpose(scA.toArray)
ary = Application.Transpose(Split(Mid(tx, 2), "~"))
Range("B2").Resize(UBound(ary), 1) = ary

End Sub

 

[Akuini]

I'm trying to simplify the code. This one is without arraylist & Do Loop:

Sub Noodles90c()
Dim i As Long, j As Long
Dim tx As String
Dim va, ary

With Sheets("Sheet2")
    va = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With
ReDim vb(1 To UBound(va, 1), 1 To 1)

tx = Range("A1")
    For i = 1 To UBound(va, 1)
        x = va(i, 1)
        If InStr(1, tx, x, vbTextCompare) Then
            j = j + 1: vb(j, 1) = x
            tx = Replace(tx, x, "~", 1, 1, vbTextCompare)
        End If
    Next

tx = Replace(tx, "~ ", "~")
Range("A2").Resize(UBound(va, 1), 1) = vb
ary = Application.Transpose(Split(Mid(tx, 2), "~"))
Range("B2").Resize(UBound(ary), 1) = ary

End Sub

 

[Noodles90]

This is much more than what I was expecting - Awesome macros - Thanks xD
@Zot - Your code unfortunately is not working well here, the titles are not pasted, and is not catching specs not related to dimensions. Thank you nonetheless.
@Akuini - Your macro is doing the job, the only issue is that the order by which the specs appear in the text is not the same as the order in the results.
This for the titles which are repeated, as for example "Ground clearance:". In the results, these titles appear together and not in the same order:

Order by the macro	Order in the sentence
Ground clearance:	Ground clearance:
Ground clearance:	Max. Towing Capacity Weight
Max. Towing Capacity Weight	Ground clearance:

This creates problems as there are many repeated titles in the long sentences I have, because the same titles appear for different categories. Sometimes with different specs.
Is there a fix for this?

@Peter_SSs Your macro works very well, but unfortunately I cannot use it as a VBA warning appears "Too many line continuations" when I add more than 25 Titles.
Is there a workaround this problem?

 

[Noodles90]

@Akuini, sorry I checked now that the version 90c is solving the issue with the order, thanks a lot!!

 

[Akuini]

@Akuini, sorry I checked now that the version 90c is solving the issue with the order, thanks a lot!!

You're welcome, glad to help & thanks for the feedback.

 

[Peter_SSs]

@Peter_SSs Your macro works very well, but unfortunately I cannot use it as a VBA warning appears "Too many line continuations" when I add more than 25 Titles.
Is there a workaround this problem?

There is no need to put each Title on a new line - I just did that for clarity. Here I have reduced them to two lines but it could even be made to one line. The titles just need to be part of a string, separated by "|" characters. How many titles do you actually have?

My code could also easily grab the titles from a list within a worksheet like Akuini's does if you would prefer that. I did it from withing the code as that was what you were attempting to do yourself.

Anyway, give this a go, by adding your extra Titles before the closing parenthesis near the end of my pattern line. If you do continue to any new lines, just follow the syntax of the line continuation that I used.

Sub SplitEmUP()
  Dim RX As Object
  Dim a As Variant, b As Variant, itm
  Dim i As Long, j As Long, k As Long, MaxRws As Long, MaxCols As Long
  
  ReDim b(1 To Rows.Count, 1 To 2)
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = "\s*(Engine size - Displacement - Engine capacity:|Body: SUV / TT Num. of Doors:|Wheelbase:|Length:|Width:|Height:|Front Axle|" & _
                "Rear Axle|Ground clearance:|Max. Towing Capacity Weight)\s*"
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value2
  For i = 1 To UBound(a)
    j = 0
    k = k + 2
    If k > MaxCols Then
      MaxCols = k
      ReDim Preserve b(1 To UBound(b), 1 To MaxCols)
    End If
    For Each itm In Split(Mid(RX.Replace(a(i, 1), "#$1@"), 2), "#")
      j = j + 1
      b(j, k - 1) = Split(itm, "@")(0): b(j, k) = Split(itm, "@")(1)
    Next itm
    If j > MaxRws Then MaxRws = j
  Next i
  Application.ScreenUpdating = False
  With Range("C2").Resize(MaxRws, MaxCols)
    .Value = b
    .Columns.AutoFit
  End With
  Application.ScreenUpdating = True
End Sub