VBA to break data in one column to different columns with dynamic range

[btyturtle]

I have a list of data in Column A. Every set of data (down the list) is always started with a "Text##" followed by numbers.

My idea is to write a macro to find that "Text", and set it as a start cell, then find the next "Text", and set it as a end cell - 1 (because I only want the data before the next "Text##"). Then keep going until every data set down the list is separated to different columns.

The set of data also has variable range (some data set longer and some shorter), and what separated them is only the "Text##" cell.

Please help and advice, I have tried different ways to go around it with no luck.

Thank you.

Below is a visualization of my description

Text87
4.5
6
8.9
7
Text99
8
8.1
Text56
1.1
2
2.3
& so on

<tbody>
</tbody>

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG26Sep40
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
Ac = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Left(Dn.Value, 4) = "Text" [COLOR="Navy"]Then[/COLOR]
        Ac = Ac + 1: c = 1
        Cells(c, Ac) = Dn.Value
    [COLOR="Navy"]Else[/COLOR]
        c = c + 1
        Cells(c, Ac) = Dn.Value
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Trebor76]

Hi btyturtle,

Welcome to MrExcel!!

This will split the data into separate but also leave the original data in Col. A (you could delete Col. A at the end of the procedure if you like):

Option Explicit
Sub Macro1()

    Dim rngMyCell As Range
    Dim lngMyCol As Long
    Dim lngMyRow As Long
    
    Application.ScreenUpdating = False
    
    For Each rngMyCell In Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        If InStr(rngMyCell, "Text") > 0 Then
            If lngMyCol = 0 Then
                lngMyCol = 2
            Else
                lngMyCol = lngMyCol + 1
            End If
            lngMyRow = 1
            Cells(lngMyRow, lngMyCol).Value = rngMyCell
        Else
            lngMyRow = lngMyRow + 1
            Cells(lngMyRow, lngMyCol).Value = rngMyCell
        End If
    Next rngMyCell
    
    Application.ScreenUpdating = True
    
    MsgBox "Done."

End Sub

Regards,

Robert

 

[btyturtle]

Thank you for your reply, MickG

I tried the code and it works perfectly. I have another question related to this, if let say I have another set of data down at Column B (this Column B has no header, because the header "Text##" is only at column A, but each of its pair is in Column A). How do I include this data in Column B to be separated next to each set of Column A as well? Thank you again.

Text87 <tbody> </tbody>
4.5	455
6	456
8.9	460
7	465
Text99
8	0
8.1	455

<tbody>
</tbody>

 

[btyturtle]

Thank you Trebor 76. I tried to run the code, it won't let me. I'll have to look at them again, so far had been trying MickG's code

 

[Rick Rothstein]

Thank you for your reply, MickG

I tried the code and it works perfectly. I have another question related to this, if let say I have another set of data down at Column B (this Column B has no header, because the header "Text##" is only at column A, but each of its pair is in Column A). How do I include this data in Column B to be separated next to each set of Column A as well? Thank you again.

Text87 <tbody> </tbody>
4.5	455
6	456
8.9	460
7	465
Text99
8	0
8.1	455

<tbody>
</tbody>

I modified MickG's code to do what you are now asking for...

Sub MG28Sep_RRmodified()
  Dim Rng As Range, Dn As Range, Ac As Long, c As Long
  Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
  Ac = 1
  For Each Dn In Rng
    If Left(Dn.Value, 4) = "Text" Then
      Ac = Ac + [B][COLOR="#0000FF"]2[/COLOR][/B]: c = 1
      Cells(c, Ac)[B][COLOR="#0000FF"].Resize(, 2)[/COLOR][/B] = Dn[B][COLOR="#0000FF"].Resize(, 2)[/COLOR][/B].Value
    Else
      c = c + 1
        Cells(c, Ac)[B][COLOR="#0000FF"].Resize(, 2)[/COLOR][/B] = Dn[B][COLOR="#0000FF"].Resize(, 2)[/COLOR][/B].Value
    End If
  Next Dn
End Sub

 

[btyturtle]

Thank you for the help. Finally, I can make some progress. Thanks a lot.