How to split dynamic list of mashed up words into separate rows without a delimiter using vba?

[Juste]

Hi All,

I have been stuck for 2 weeks now trying to work this out. Can somebody please enlighten me?
I simplified my request and changed raw data into words so it would make some sense of what I would like to achieve.

There is a column B of dynamic mashed up data.
This data needs to be split into words and each word displayed onto separate row (Result in Column C).
As a helper there is a column A to do a lookup of how the words are meant to be separated.

[TABLE="width: 436"]
<tbody>[TR]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[/TR]
[TR]
[TD]green[/TD]
[TD]light greyyellowred gold[/TD]
[TD]light grey[/TD]
[/TR]
[TR]
[TD]yellow[/TD]
[TD]greenblackwhite[/TD]
[TD]yellow[/TD]
[/TR]
[TR]
[TD]light grey[/TD]
[TD]silver[/TD]
[TD]red gold[/TD]
[/TR]
[TR]
[TD]cooper[/TD]
[TD]bronzemidnight blue[/TD]
[TD]green[/TD]
[/TR]
[TR]
[TD]red gold[/TD]
[TD][/TD]
[TD]black[/TD]
[/TR]
[TR]
[TD]silver[/TD]
[TD][/TD]
[TD]white[/TD]
[/TR]
[TR]
[TD]black[/TD]
[TD][/TD]
[TD]silver[/TD]
[/TR]
[TR]
[TD]white[/TD]
[TD][/TD]
[TD]bronze[/TD]
[/TR]
[TR]
[TD]midnight blue[/TD]
[TD][/TD]
[TD]midnight blue[/TD]
[/TR]
[TR]
[TD]antique brass[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]bronze[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

What I've already tried to do is to use Concatenate function to add up all data in column B. Then Index, Match & Countif functions to do a lookup and then Substitute function to split data.
However, my Index Match Countif function works too slow on a big amount of data.
I was wondering is there another way to approach it please?

Many thanks
Juste

 

[nemmi69]

will VBa do?

 

[Juste]

will VBa do?

I really hope so

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG18Jul39
[COLOR="Navy"]Dim[/COLOR] RngA [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, R [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] RngB [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] RngA = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]Set[/COLOR] RngB = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] RngB
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] RngA
        [COLOR="Navy"]If[/COLOR] InStr(Dn.Value, R.Value) > 0 [COLOR="Navy"]Then[/COLOR]
            c = c + 1
            Cells(c, 3) = R.Value
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] R
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Juste]

Try this:-

[COLOR=Navy]Sub[/COLOR] MG18Jul39
[COLOR=Navy]Dim[/COLOR] RngA [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range, R [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] RngB [COLOR=Navy]As[/COLOR] Range, c [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Set[/COLOR] RngA = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[COLOR=Navy]Set[/COLOR] RngB = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] RngB
    [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] R [COLOR=Navy]In[/COLOR] RngA
        [COLOR=Navy]If[/COLOR] InStr(Dn.Value, R.Value) > 0 [COLOR=Navy]Then[/COLOR]
            c = c + 1
            Cells(c, 3) = R.Value
        [COLOR=Navy]End[/COLOR] If
    [COLOR=Navy]Next[/COLOR] R
[COLOR=Navy]Next[/COLOR] Dn
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]

Regards Mick

Hi Mick,

OMG, it worked!! I've just changed RngB value to display more data. You're genius!! I can't believe it's working

Thank you!
Juste

 

[nemmi69]

Sub SplitMashed()
Dim DataLoop As Long
Dim SourceLoop As Integer
Dim ColourArray
Dim LBColourAr As Integer
Dim UBColourAr As Integer
Dim OrigString As String
Dim TempString As String
Dim RowCount As Integer


'set colours that can be found
ColourArray = Application.Transpose(ActiveSheet.Range("I15:I25").Value)
LBColourAr = LBound(ColourArray)
UBColourAr = UBound(ColourArray)
'First row of output data
RowCount = 15


'Data range J15 to J18
For DataLoop = 15 To 18
    OrigString = ActiveSheet.Range("J" & DataLoop).Value
    For SourceLoop = LBColourAr To UBColourAr
        If InStr(1, OrigString, ColourArray(SourceLoop)) = 1 Then
            'Output range in column L
            ActiveSheet.Range("L" & RowCount).Value = ColourArray(SourceLoop)
            RowCount = RowCount + 1
            OrigString = Right(OrigString, Len(OrigString) - Len(ColourArray(SourceLoop)))
        End If
        If InStr(1, OrigString, ColourArray(SourceLoop)) > 1 Then
            'Output range in column L
            ActiveSheet.Range("L" & RowCount).Value = ColourArray(SourceLoop)
            RowCount = RowCount + 1
            TempString = Left(OrigString, InStr(1, OrigString, ColourArray(SourceLoop)) - 1)
            OrigString = Right(OrigString, Len(OrigString) - Len(ColourArray(SourceLoop)))
            OrigString = TempString & OrigString
        End If
    Next SourceLoop
Next DataLoop
End Sub

 

[Juste]

Thank you so much nemmi69!! Your code worked too!! I'm so happy

Juste

 

[MickG]

You're welcome