TEXT to Rows , using a Macro ? Or Funcation

[jwalkerack]

Hi there ,

what i would like to do is use a function that is similar to the Text to columns , but instead do Text to rows.

So for example my table would start off being like this

[TABLE="width: 389"]
<COLGROUP><COL style="WIDTH: 142pt; mso-width-source: userset; mso-width-alt: 6912" width=189><COL style="WIDTH: 134pt; mso-width-source: userset; mso-width-alt: 6546" width=179><COL style="WIDTH: 113pt; mso-width-source: userset; mso-width-alt: 5522" width=151><TBODY>[TR]
[TD="class: xl65, width: 189, bgcolor: #dce6f1"]Player [/TD]
[TD="class: xl65, width: 179, bgcolor: #dce6f1"]Team [/TD]
[TD="class: xl65, width: 151, bgcolor: #dce6f1"]Country [/TD]
[/TR]
[TR]
[TD="class: xl66, bgcolor: #ddd9c4"]Henry & Wright & Dixon [/TD]
[TD="class: xl67, bgcolor: #ebf1de"]Arsenal [/TD]
[TD="class: xl68, bgcolor: #fde9d9"]England [/TD]
[/TR]
[TR]
[TD="class: xl66, bgcolor: #ddd9c4"]Rooney & Di Maria [/TD]
[TD="class: xl67, bgcolor: #ebf1de"]Manchester United [/TD]
[TD="class: xl68, bgcolor: #fde9d9"]England [/TD]
[/TR]
[TR]
[TD="class: xl66, bgcolor: #ddd9c4"]Messi & Xavi[/TD]
[TD="class: xl67, bgcolor: #ebf1de"]Barcelona [/TD]
[TD="class: xl68, bgcolor: #fde9d9"]Spain [/TD]
[/TR]
</TBODY>[/TABLE]


I would like to do a text to rows on column A

So the end output would be like this

[TABLE="width: 291"]
<COLGROUP><COL style="WIDTH: 115pt; mso-width-source: userset; mso-width-alt: 5595" width=153><COL style="WIDTH: 108pt; mso-width-source: userset; mso-width-alt: 5266" width=144><COL style="WIDTH: 68pt; mso-width-source: userset; mso-width-alt: 3328" width=91><TBODY>[TR]
[TD="class: xl65, width: 153, bgcolor: #dce6f1"]Player [/TD]
[TD="class: xl65, width: 144, bgcolor: #dce6f1"]Team[/TD]
[TD="class: xl65, width: 91, bgcolor: #dce6f1"]Country [/TD]
[/TR]
[TR]
[TD="class: xl66, bgcolor: #ddd9c4"]Henry[/TD]
[TD="class: xl67, bgcolor: #ebf1de"]Arsenal [/TD]
[TD="class: xl68, bgcolor: #fde9d9"]England [/TD]
[/TR]
[TR]
[TD="class: xl66, bgcolor: #ddd9c4"]Wright[/TD]
[TD="class: xl67, bgcolor: #ebf1de"]Arsenal [/TD]
[TD="class: xl68, bgcolor: #fde9d9"]England [/TD]
[/TR]
[TR]
[TD="class: xl66, bgcolor: #ddd9c4"]Dixon[/TD]
[TD="class: xl67, bgcolor: #ebf1de"]Arsenal [/TD]
[TD="class: xl68, bgcolor: #fde9d9"]England [/TD]
[/TR]
[TR]
[TD="class: xl66, bgcolor: #ddd9c4"]Rooney[/TD]
[TD="class: xl67, bgcolor: #ebf1de"]Manchester United [/TD]
[TD="class: xl68, bgcolor: #fde9d9"]England [/TD]
[/TR]
[TR]
[TD="class: xl66, bgcolor: #ddd9c4"]DiMaria[/TD]
[TD="class: xl67, bgcolor: #ebf1de"]Manchester United [/TD]
[TD="class: xl68, bgcolor: #fde9d9"]England [/TD]
[/TR]
[TR]
[TD="class: xl66, bgcolor: #ddd9c4"]Messi[/TD]
[TD="class: xl67, bgcolor: #ebf1de"]Barcelona [/TD]
[TD="class: xl68, bgcolor: #fde9d9"]Spain [/TD]
[/TR]
[TR]
[TD="class: xl66, bgcolor: #ddd9c4"]Xavi[/TD]
[TD="class: xl67, bgcolor: #ebf1de"]Barcelona [/TD]
[TD="class: xl68, bgcolor: #fde9d9"]Spain [/TD]
[/TR]
</TBODY>[/TABLE]


Using the & to delimeter the rows. I have seen some code online but have not been able to get to work . Does any one have some ideas .

Thanks a lot

 

[mikerickson]

This might work for you. It acts on the ActiveCell.CurrentRegion. That might need to be changed.

Sub test()
    Dim SelectedRange As Range
    Dim uiDelimiter As String
    Set SelectedRange = ActiveCell.CurrentRegion
    
    uiDelimiter = Application.InputBox("Text To Rows on " & SelectedRange.Address & vbCr & "With delimiter", Default:=" & ", Type:=2)
    If uiDelimiter = vbNullString Then Exit Sub: Rem canceled
    Call TextToRows(SelectedRange, uiDelimiter)
End Sub

Sub TextToRows(aRange As Range, Optional Delimiter As String = " ")
    Dim outArray As Variant, colCount As Long
    Dim Words As Variant
    Dim i As Long, j As Long, k As Long
    Dim Pointer As Long
    
    colCount = aRange.Columns.Count
    ReDim outArray(1 To colCount, 1 To aRange.Rows.Count)
    
    For i = 1 To aRange.Rows.Count
        Words = Split(aRange.Cells(i, 1), Delimiter)
        For j = 0 To UBound(Words)
            Pointer = Pointer + 1
            If UBound(outArray, 2) < Pointer Then ReDim Preserve outArray(1 To colCount, 1 To 2 * Pointer)
                outArray(1, Pointer) = Words(j)
            For k = 2 To colCount
                outArray(k, Pointer) = aRange.Cells(i, k)
            Next k
        Next j
    Next i
    ReDim Preserve outArray(1 To colCount, 1 To Pointer)
    aRange.Resize(UBound(outArray, 2), UBound(outArray, 1)).Value = Application.Transpose(outArray)
End Sub

 

[Andrew Poulsom]

What code have you seen on line and in what way didn't it work?

 

[jwalkerack]

Hi there , thanks for getting back i give that first one a go and see if it works

The code i have seen on line are in the below links. For the second question i am not sure lol , i might not be modifiying it corrently to my sheet


http://www.mrexcel.com/forum/excel-questions/707841-text-rows-visual-basic-applications.html

Text to Rows VBA Excel - Stack Overflow

 

[jwalkerack]

I tried the first code , the error message i get is

Run time error 424

Object required

With this part highlighted in the code section


colCount = aRange.Columns.Count

 

[mikerickson]

You should be calling the test macro, not the TextToRows.