Hello,

I need help! I have spreadsheets with tons of data and I am looking
to write a macro to do what i need. I have varrying number of data
within a cell and need to seperate them out. I current do text to
columns to seperate into seperate columns. Then I count the number of
columns in each row, and then insert that number of rows below and
then copy and paste special transpose to get them into their own
rows. The are in the fourth column of data. I then copy down the
first three columns over and over for each value.

I do very beginner code writing as this is not my training or job, but
I can usually figure it out. I am stuck on this one, any help is
appreciated.

Thanks,
A

On Sep 20, 9:46*am, Adrienne Miller wrote:
Hello,

I need help! *I have spreadsheets with tons of data and I am looking
to write a macro to do what i need. *I have varrying number of data
within a cell and need to seperate them out. *I current do text to
columns to seperate into seperate columns. *Then I count the number of
columns in each row, and then insert that number of rows below and
then copy and paste special transpose to get them into their own
rows. *The are in the fourth column of data. *I then copy down the
first three columns over and over for each value.

I do very beginner code writing as this is not my training or job, but
I can usually figure it out. *I am stuck on this one, any help is
appreciated.

Thanks,
A

Send your file with a complete explanation and examples to dguillett1
@gmail.com

Here's one way...

Sub SplitCellDataToRows()
Dim v, vDataIn, vTemp(), vDataOut() 'as type Variant
Dim n&, x&, k&, lRowsIn&, lColsOut& 'as type Long
Dim sPad As String

Const sDelimiter As String = " " '//revise to suit

'Parse the data into an array of arrays
lRowsIn = ActiveSheet.UsedRange.Rows.Count
vDataIn = Range(Cells(1, 1), Cells(lRowsIn, 1))
ReDim vTemp(1 To lRowsIn)
For n = LBound(vDataIn) To UBound(vDataIn)
vTemp(n) = Split(vDataIn(n, 1), sDelimiter)
x = UBound(vTemp(n)) + 1
If x lColsOut Then lColsOut = x
Next 'n

'Pad any missing data to match column output
ReDim vDataOut(1 To lRowsIn, 1 To lColsOut)
For n = 1 To lRowsIn
x = (UBound(vTemp(n)) + 1): sPad = Join(vTemp(n), sDelimiter)
If x < lColsOut Then sPad = sPad _
& Application.WorksheetFunction.Rept(sDelimiter, lColsOut - x)
k = 1
For Each v In Split(sPad, sDelimiter)
vDataOut(n, k) = v: k = k + 1
Next 'v
Next 'n

'Write the data back to the same rows
Range("A1").Resize(lRowsIn, lColsOut) = vDataOut
End Sub

This assumes the data is a 'text dump' stored in colA, and all cols to
the right are empty. It does not preserve the original data in colA.

--
Garry

Free usenet access at http://www.eternal-september.org
ClassicVB Users Regroup! comp.lang.basic.visual.misc

Here's another way that allows you to choose where the output goes by
changing the constant 'lOutputCol' in the final loop. Also, it writes
to the worksheet one row at a time.


Sub SplitCellDataToCols()
Dim v, vDataIn 'as type Variant
Dim n&, x&, lRowsIn&, lColsOut& 'as type Long

Const sDelimiter As String = " " '//revise to suit
Const lOutputCol As Long = 2 '//revise to suit

lRowsIn = ActiveSheet.UsedRange.Rows.Count
vDataIn = Range(Cells(1, 1), Cells(lRowsIn, 1))

'Get the number of output columns
For n = LBound(vDataIn) To UBound(vDataIn)
v = Split(vDataIn(n, 1), sDelimiter)
x = UBound(v) + 1: If x lColsOut Then lColsOut = x
Next 'n

'Parse the data out (row by row)
Application.ScreenUpdating = False
For n = LBound(vDataIn) To UBound(vDataIn)
v = Split(vDataIn(n, 1), sDelimiter)
Cells(n, lOutputCol).Resize(1, lColsOut) = _
Split(Join(v, sDelimiter) _
& Application.WorksheetFunction.Rept(sDelimiter, _
lColsOut - (UBound(v) + 1)), sDelimiter)
Next 'n
Application.ScreenUpdating = True
End Sub

--
Garry

Free usenet access at http://www.eternal-september.org
ClassicVB Users Regroup! comp.lang.basic.visual.misc

On Sep 20, 7:29*pm, GS wrote:
Here's another way that allows you to choose where the output goes by
changing the constant 'lOutputCol' in the final loop. Also, it writes
to the worksheet one row at a time.

Sub SplitCellDataToCols()
* Dim v, vDataIn 'as type Variant
* Dim n&, x&, lRowsIn&, lColsOut& 'as type Long

* Const sDelimiter As String = " " '//revise to suit
* Const lOutputCol As Long = 2 '//revise to suit

* lRowsIn = ActiveSheet.UsedRange.Rows.Count
* vDataIn = Range(Cells(1, 1), Cells(lRowsIn, 1))

* 'Get the number of output columns
* For n = LBound(vDataIn) To UBound(vDataIn)
* * v = Split(vDataIn(n, 1), sDelimiter)
* * x = UBound(v) + 1: If x lColsOut Then lColsOut = x
* Next 'n

* 'Parse the data out (row by row)
* Application.ScreenUpdating = False
* For n = LBound(vDataIn) To UBound(vDataIn)
* * v = Split(vDataIn(n, 1), sDelimiter)
* * Cells(n, lOutputCol).Resize(1, lColsOut) = _
* * * Split(Join(v, sDelimiter) _
* * * & Application.WorksheetFunction.Rept(sDelimiter, _
* * * lColsOut - (UBound(v) + 1)), sDelimiter)
* Next 'n
* Application.ScreenUpdating = True
End Sub

--
Garry

Free usenet access athttp://www.eternal-september.org
ClassicVB Users Regroup! comp.lang.basic.visual.misc
======================
Here is what I sent
Option Explicit

Sub LineEmUpSAS()
Dim i As Long
Dim lc As Long


Application.ScreenUpdating = False

Columns("D").TextToColumns Destination:=Range("D1"),
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False,
Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False

On Error Resume Next
For i = ActiveSheet.UsedRange.Rows.Count To 2 Step -1
lc = Cells(i, Columns.Count).End(xlToLeft).Column - 4
Rows(i + 1).Resize(lc).Insert
Cells(i, "e").Resize(, lc).Copy
Cells(i + 1, "d").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
Transpose:=True
Cells(i, 1).Resize(, 3).AutoFill Destination:=Cells(i, 1).Resize(lc +
1, 3), Type:=xlFillCopy
Next i

'housekeeping
lc = Cells.Find("*", Cells(Rows.Count, Columns.Count) _
, , , xlByColumns, xlPrevious).Column
Columns("e").Resize(, lc).Delete
Columns("B:D").WrapText = False
Range("c1:D1").WrapText = True
Columns("D").NumberFormat = "@"
Columns("b").AutoFit
Columns("a").ColumnWidth = 6
Columns("C").ColumnWidth = 9.22
Columns("D").ColumnWidth = 7.33
Rows.AutoFit
ActiveSheet.UsedRange.Borders.LineStyle = xlContinuous
Range("b2").Select

Application.ScreenUpdating = True
End Sub

Don Guillett laid this down on his screen :
On Sep 20, 7:29*pm, GS wrote:
Here's another way that allows you to choose where the output goes by
changing the constant 'lOutputCol' in the final loop. Also, it writes
to the worksheet one row at a time.

Sub SplitCellDataToCols()
* Dim v, vDataIn 'as type Variant
* Dim n&, x&, lRowsIn&, lColsOut& 'as type Long

* Const sDelimiter As String = " " '//revise to suit
* Const lOutputCol As Long = 2 '//revise to suit

* lRowsIn = ActiveSheet.UsedRange.Rows.Count
* vDataIn = Range(Cells(1, 1), Cells(lRowsIn, 1))

* 'Get the number of output columns
* For n = LBound(vDataIn) To UBound(vDataIn)
* * v = Split(vDataIn(n, 1), sDelimiter)
* * x = UBound(v) + 1: If x lColsOut Then lColsOut = x
* Next 'n

* 'Parse the data out (row by row)
* Application.ScreenUpdating = False
* For n = LBound(vDataIn) To UBound(vDataIn)
* * v = Split(vDataIn(n, 1), sDelimiter)
* * Cells(n, lOutputCol).Resize(1, lColsOut) = _
* * * Split(Join(v, sDelimiter) _
* * * & Application.WorksheetFunction.Rept(sDelimiter, _
* * * lColsOut - (UBound(v) + 1)), sDelimiter)
* Next 'n
* Application.ScreenUpdating = True
End Sub

--
Garry

Free usenet access athttp://www.eternal-september.org
ClassicVB Users Regroup! comp.lang.basic.visual.misc
======================
Here is what I sent
Option Explicit

Sub LineEmUpSAS()
Dim i As Long
Dim lc As Long


Application.ScreenUpdating = False

Columns("D").TextToColumns Destination:=Range("D1"),
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False,
Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False

On Error Resume Next
For i = ActiveSheet.UsedRange.Rows.Count To 2 Step -1
lc = Cells(i, Columns.Count).End(xlToLeft).Column - 4
Rows(i + 1).Resize(lc).Insert
Cells(i, "e").Resize(, lc).Copy
Cells(i + 1, "d").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
Transpose:=True
Cells(i, 1).Resize(, 3).AutoFill Destination:=Cells(i, 1).Resize(lc +
1, 3), Type:=xlFillCopy
Next i

'housekeeping
lc = Cells.Find("*", Cells(Rows.Count, Columns.Count) _
, , , xlByColumns, xlPrevious).Column
Columns("e").Resize(, lc).Delete
Columns("B:D").WrapText = False
Range("c1:D1").WrapText = True
Columns("D").NumberFormat = "@"
Columns("b").AutoFit
Columns("a").ColumnWidth = 6
Columns("C").ColumnWidth = 9.22
Columns("D").ColumnWidth = 7.33
Rows.AutoFit
ActiveSheet.UsedRange.Borders.LineStyle = xlContinuous
Range("b2").Select

Application.ScreenUpdating = True
End Sub

Looks like you got a sample file from OP and catered exactly to that.
My offerings are more generic and so not as much detail!<g

--
Garry

Free usenet access at http://www.eternal-september.org
ClassicVB Users Regroup! comp.lang.basic.visual.misc

Don,
Nice example of how to use TextToColumns with VBA! Thanks for
posting...

--
Garry

Free usenet access at http://www.eternal-september.org
ClassicVB Users Regroup! comp.lang.basic.visual.misc

On Sep 21, 3:29*pm, GS wrote:
Don,
Nice example of how to use TextToColumns with VBA! Thanks for
posting...

--
Garry

Free usenet access athttp://www.eternal-september.org
ClassicVB Users Regroup! comp.lang.basic.visual.misc


I did get his file and, thanks!