Text To Columns then insert rows

[Adrienne Miller]

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

 

[Don Guillett]

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

 

[GS]

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.

 

[GS]

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

 

[Don Guillett]

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").WrapText = False
Range("c11").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

 

[GS]

Don Guillett laid this down on his screen :

======================
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").WrapText = False
Range("c11").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>

 

[GS]

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

 

[Don Guillett]

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!