Consulting

Results 1 to 7 of 7

Thread: Solved: Split cell contents into multiple rows

  1. #1
    VBAX Newbie
    Joined
    Jan 2007
    Posts
    3
    Location

    Solved: 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
    Attached Files Attached Files

  2. #2
    VBAX Tutor
    Joined
    Nov 2006
    Location
    North East Pennsylvania, USA
    Posts
    203
    Location
    bugsyb6,

    Welcome to the VBA Express forum.

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


    Have a great day,
    Stan
    Attached Files Attached Files

  3. #3
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,954
    Location
    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.

    [VBA]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[/VBA]

  4. #4
    VBAX Newbie
    Joined
    Jan 2007
    Posts
    3
    Location
    All I can say is WOW! 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

  5. #5
    VBAX Tutor
    Joined
    Nov 2006
    Location
    North East Pennsylvania, USA
    Posts
    203
    Location
    bugsyb6,

    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:


    [VBA]

    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

    [/VBA]



    Hope this helps you understand what is going on.


    Have a great day,
    Stan

  6. #6
    VBAX Newbie
    Joined
    Jan 2007
    Posts
    3
    Location
    Stan -

    That explains it all very well. Thanks.

    Pam

  7. #7

    thank you

    this is really great!

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •