Split cell contents into multiple rows

This is my first post here so I apologize if it's not quite right.

I'm running Excel 2003 and only know very basic VBA. I found something similar to my issue in another post but have no idea how to make it work for my situation.

Here's the deal. I have a workbook with one worksheet holding data that is being used for a look up on another worksheet. My issue is that some of the data in the holding worksheet has multiple values in cells in column E. I need that data split out into separate rows so there is only one value in column E and the values in the remaining columns in that row get copied. I've attached an example of what I'm looking for.

Can anyone show me how to make this happen?

Thanks -
Pam

bugsyb6,

Welcome to the VBA Express forum.

Detach/open workbook bugsyb6 - VE36040 - SDG12.xls and run macro ReorgData.


Have a great day,
Stan

Good example file for your first post.

In my solution, copy this code to a Module. Click Insert > Module in the VBE to add one. Notice that I just added the data to Sheet2 rather than modify Sheet1.

Code:

---

Sub ParseColsEandF()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim E() As String, F() As String
    Dim Rws1 As Long, Rws2 As Long
    Dim r As Range
    Dim i As Integer
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    ' Copy header row
    ws1.Range("A1:G1").Copy ws2.Range("A1:G1")
    Rws1 = 2
    Rws2 = 2
    Do
        ' Check to end loop
        Set r = ws1.Range("A" & Rws1)
        ' Split columns E and F.  Note: Assumes E and F have same number of commas.
        E() = Split(Replace(ws1.Range("E" & Rws1).Value, ", ", ","), ",")
        F() = Split(Replace(ws1.Range("F" & Rws1).Value, ", ", ","), ",")
        For i = LBound(E) To UBound(E)
            ' Copy whole row to maintain formats.
            ws1.Range("A" & Rws1 & ":G" & Rws1).Copy ws2.Range("A" & Rws2 & ":G" & Rws2)
            ws2.Range("E" & Rws2).Value = E(i)
            ws2.Range("F" & Rws2).Value = F(i)
            Rws2 = Rws2 + 1
      Next i
      Rws1 = Rws1 + 1
    Loop Until (r.Value = Empty)
    ' Refit
    ws2.UsedRange.Columns("A:G").AutoFit
End Sub

---

All I can say is WOW! :bow: You guys are the Van Gogh of VBA while I'm still learning to color in the lines!

Both solutions do exactly what I want them to do. Thank you both very much. I think I will go with Stan's solution only because it keeps the data on the same worksheet.

Stan - Looking at your code (and trying to learn from it), it appears that it counts the number of commas in the cell in column E and then inserts that many rows. The part I'm not sure about is how does it know what to delete from each row after it copies the original data into the new rows?

Thanks again -
Pam

bugsyb6,

Quote:

---

Stan - Looking at your code (and trying to learn from it), it appears that it counts the number of commas in the cell in column E and then inserts that many rows. The part I'm not sure about is how does it know what to delete from each row after it copies the original data into the new rows?

---

See below in bold an explanation of the lines of code:

Code:

---

Option Explicit

Sub ReorgData()
    ' stanleydgrom, 02/07/2011
    ' http://www.vbaexpress.com/forum/showthread.php?t=36040
    Dim LR As Long, a As Long, Sp, Sp2
    Application.ScreenUpdating = False
    With Worksheets("Sheet1")
        LR = .Cells(Rows.Count, 1).End(xlUp).Row
        For a = LR To 2 Step -1
            ' Lets use cell E7 as an example
            ' If there are any , characters
            If InStr(.Cells(a, 5), ",") > 0 Then
                ' Sp is an array, in this case the array contain 5 elements,
                '  Sp(0) thru Sp(4)               
                Sp = Split(Trim(.Cells(a, 5)), ",")
                ' The upper bound of array Sp is Sp(4)
                ' So we insert 4 rows in/at row 8               
                .Rows(a + 1).Resize(UBound(Sp)).EntireRow.Insert
                ' This is copying A7:G7 to A8:G11               
                .Range("A" & a + 1 & ":G" & a + 1).Resize(UBound(Sp)).Value = .Range("A" & a & ":G" & a).Value
                ' Change the format of the cells in range E7:E11 to text               
                .Range("E" & a).Resize(UBound(Sp) + 1).NumberFormat = "@"
                ' Transpose the Sp array into range E7:E11               
                .Range("E" & a).Resize(UBound(Sp) + 1).Value = Application.Transpose(Sp)
                ' The next three lines of code splits the data in cell F7
                '  and then transpose the Sp2 array into range F7:F11               
                Sp2 = Split(Trim(.Cells(a, 6)), ", ")
                .Range("F" & a).Resize(UBound(Sp2) + 1).NumberFormat = "@"
                .Range("F" & a).Resize(UBound(Sp2) + 1).Value = Application.Transpose(Sp2)
            End If
        Next a
        LR = .Cells(Rows.Count, 1).End(xlUp).Row
        .Range("E2:E" & LR).Replace What:=" ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    End With
    Application.ScreenUpdating = True
End Sub

---

Hope this helps you understand what is going on.


Have a great day,
Stan

Stan -

That explains it all very well. Thanks.

Pam

this is really great!