Parsing, separating, inserting. copying

  • Thread starter Thread starter Philipgrae
  • Start date Start date
P

Philipgrae

Hi all,

I have a challenge with a worksheet that contains a column of
delimited data, which needs separating and adding to new rows in the
column. The delimiter is ";#"
For example:

Col A Col
B Col C Col D
Row 1 02/06/09 Fred
Apples;#Pears;#Bananas text
Row 2 03/06/09 Emma
Oranges;#Pears text
Row 3 04/06/09 George
Oranges text

I have a brilliant script written by Tom Ogilvy that I found on here
which parses and separates the data like this......

Col A Col
B Col C Col D
Row
1
Apples
Row
2
Pears
Row 3 02/06/09 Fred
Bananas text
Row
4
Oranges
Row 5 03/06/09 Emma
Pears text
Row 6 04/06/09 George
Oranges text

However I need the rest of the data in the row from whence the
deliminated data came to be repeated by the muber of elements in the
delimited string (ie the number of rows inserted by the macro). Please
note the code inserts these rows above the original.

This example is just that... in the real thing the delimited data is
in Column AA, and the data extends from Column A to Column AB.

I've pasted Tom's code below in the hope anyone can amend it to solve
my problem - I have tried to do it myself but it's pushing the edge my
VBA envelope a bit too far!

Many thanks in anticipation,

Phil

Function Split(sStr As Variant, sdelim As String) As Variant
Split = Evaluate("{""" & _
Application.Substitute(sStr, sdelim, """,""") & """}")
End Function


Sub testme()
Dim iRow As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim wks As Worksheet
Dim mySplit As Variant
Dim myStr As String
Dim NumberOfElements As Long


Set wks = Worksheets("sheet1")


With wks
FirstRow = 1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row


For iRow = LastRow To FirstRow Step -1
myStr = .Cells(iRow, "AA").Value
If Len(myStr) > 0 Then
mySplit = Split(myStr, ";#")
NumberOfElements = UBound(mySplit) - LBound(mySplit) +
1
If NumberOfElements > 1 Then
.Cells(iRow, "AA").Resize(NumberOfElements - 1) _
.EntireRow.Insert
.Cells(iRow, "AA").Resize(NumberOfElements).Value
_
= Application.Transpose(mySplit)
End If
End If
Next iRow
End With


End Sub
 
Just seen what a mess the data looks like when posted.....

To explain, there should be four columns in the example, A to D. In
each is a piece of data (Date, Name, Delimited text and Text.

There are four rows, 1 to 4.

In the output, ther are still four columns, with the delimited text
separated out into new rows, thus increasing the number of rows in the
set to 6.

I need the non-delimited data that remains in the set to be copied UP
into the blank cells created by the separation and placement of the
delimited data.

I hope that makes sense!

P ;)
 
Just seen what a mess the data looks like when posted.....

To explain, there should be four columns in the example, A to D. In
each is a piece of data (Date, Name, Delimited text and Text.

There are four rows, 1 to 4.

In the output, ther are still four columns, with the delimited text
separated out into new rows, thus increasing the number of rows in the
set to 6.

I need the non-delimited data that remains in the set to be copied UP
into the blank cells created by the separation and placement of the
delimited data.

I hope that makes sense!

P ;)
Click to expand...

Perhaps not so elegant as Tom's, but it should work to do what you describe.

It was not clear to me from your descriptions if your original data had only
four columns, or if there could be more. I wrote the routine so it would
handle n columns.

Important assumptions:
Delimited text is in column 1
Data Source is a NAME'd range (named on the worksheet).
Destination starts in A1, and a A1.CurrentRegion.ClearContents will not
destroy anything valuable. But you may want to look at this method of clearing
out old data critically before applying it.

=============================
Option Explicit
Sub ReformatData()
Dim rSrc As Range, c As Range, rDest As Range
Dim i As Long, j As Long, k As Long
Dim sTemp() As String
Const sSep As String = ";#"

Set rSrc = Range("OrigDataTbl")
Set rDest = Range("A1")

rDest.CurrentRegion.ClearContents

i = 0
For j = 1 To rSrc.Rows.Count
Set rDest = rDest(1 + i, 1)
Set c = rSrc(j, 1)
sTemp = Split(c.Value, sSep)
For i = 0 To UBound(sTemp)
rDest(i + 1, 1).Value = sTemp(i)
For k = 2 To rSrc.Columns.Count
With rDest(i + 1, k)
.Value = c(1, k)
.NumberFormat = c(1, k).NumberFormat
End With
Next k
Next i
Next j
End Sub
==============================
--ron
 
Back
Top