Results 1 to 15 of 15
  1. #1
    New Lounger
    Join Date
    Dec 2012
    Posts
    7
    Thanks
    0
    Thanked 0 Times in 0 Posts

    VBA for Excel - Copy rows and populate with split cell values

    Hey cats,

    I have a spreadsheet that contains rows of data. Occasionally, a cell in a row will contain multiple values, separated by Alt-Enter (Chr(10)). I would like to:

    1. Locate each occurrence of cells with multiple values (sequentially).
    2. Grab the values and split them into an array.
    3. Insert blank rows below the row where I found a match, to match the number of values I found in my array.
    4. Populate each blank row with the contents of the row above it.
    5. Replace the cells with repeating values with the individual values from my array.

    Data looks something like:

    Excel.png

    I would like to turn it into:

    Excel2.png

    I have some cobbled together code that does #2, #3, and part of #5, but what is getting me is the flow and how to increment rows, insert into specific cells, how to not have cell references hard-coded, etc. What I have so far looks like the following:

    Code:
    Sub ExpandPNs()
    ' Routine to automatically expand Part Numbers where multiples have been
    ' entered into a single cell, using Alt-Enter.
    
    Dim splitVals As Variant
    Dim totalVals As Long
    
    splitVals = Split(ActiveCell.Value, Chr(10))
    totalVals = UBound(splitVals) + 1
    MsgBox "splitVals = " & totalVals
    
    Dim lcount As Long
    Dim lNum As Long
    Dim PNList As Long
    Dim CellNum As Long
    
    PNList = 0
    lcount = 0
    lNum = 1
    PartList = totalVals
    
    Do While lNum <= totalVals
        ActiveCell.Offset(1).EntireRow.Insert
        Range("C2").Offset(1, 0).Select
        Range("C3").Value = Range("C2").Value
        lNum = lNum + 1
        PNList = PNList + 1
    
    Loop
    
    End Sub
    Any pointers on how I could automatically rip through a spreadsheet would be great.

    Thanks!
    Last edited by Chunkstyle; 2012-12-05 at 16:35. Reason: Clear up table.

  2. #2
    WS Lounge VIP rory's Avatar
    Join Date
    Dec 2000
    Location
    Burwash, East Sussex, United Kingdom
    Posts
    6,280
    Thanks
    3
    Thanked 191 Times in 177 Posts
    Will you know in advance which column has the multiple data cells in it? Also, can there be multiple columns with multiple data cells in them?
    Regards,
    Rory

    Microsoft MVP - Excel

  3. #3
    New Lounger
    Join Date
    Dec 2012
    Posts
    7
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Hi Rory,

    I will know in advance which column will contain multiple cells, and will concentrate the parsing on it. For now, let's assume that there is only once cell with multiple values in it. The real-world example is that there are multiple vendor part numbers associated to an internal part number. All of the other data should be the same across the row.

    Thanks!

    Greg

  4. #4
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,433
    Thanks
    371
    Thanked 1,456 Times in 1,325 Posts
    Greg,

    This should do the trick if I understand your requirements correctly.
    Code:
    Sub ExpandPNs()
    
    ' Routine to automatically expand Part Numbers where multiples have been
    ' entered into a single cell, using Alt-Enter.
    
       Dim vSplitVals As Variant
       Dim lValCnt    As Long
       Dim lCntr      As Long
    
       [A2].Select
       
       Do
         vSplitVals = Split(ActiveCell.Offset(0, 2).Value, Chr(10))
         lValCnt = UBound(vSplitVals)
    
         ActiveCell.Offset(0, 2) = vSplitVals(0)
    
         If lValCnt > 0 Then
          For lCntr = 1 To lValCnt
         
             With ActiveCell
                 .Offset(lCntr, 0).EntireRow.Insert
                 .Offset(lCntr, 0).Value = .Value
                 .Offset(lCntr, 1).Value = .Offset(0, 1).Value
                 .Offset(lCntr, 2).Value = .Offset(0, 2).Value
                 .Offset(lCntr, 3).Value = .Offset(0, 3).Value
             End With
                
           Next  'lCntr
         
         End If  'lvalCnt > 1
         
         ActiveCell.Offset(lValCnt + 1, 0).Select
         
       Loop While ActiveCell.Value <> ""
       
       Rows("1:" & ActiveCell.Row).EntireRow.AutoFit
    
    End Sub
    Attached Files Attached Files
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  5. #5
    New Lounger
    Join Date
    Dec 2012
    Posts
    7
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Hi RG,

    That is really close. It's not expanding each of the values found in a cell into the separate rows, but repeating the first value in the cell across all rows. So close!

    Greg

  6. #6
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,433
    Thanks
    371
    Thanked 1,456 Times in 1,325 Posts
    Greg,

    OOPS!

    Sorry about that! I was so happy with myself I wasn't seeing straight.

    You just need to replace this line .Offset(lCntr, 2).Value = .Offset(0, 2).Value
    with this. .Offset(lCntr, 2).Value = vSplitVals(lCntr)
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  7. #7
    WS Lounge VIP rory's Avatar
    Join Date
    Dec 2000
    Location
    Burwash, East Sussex, United Kingdom
    Posts
    6,280
    Thanks
    3
    Thanked 191 Times in 177 Posts
    Here's a slightly more generic version:
    Code:
    Sub ExpandPNs()' Routine to automatically expand Part Numbers where multiples have been
    ' entered into a single cell, using Alt-Enter.
       Application.ScreenUpdating = False
       ExpandData Range("A1").CurrentRegion, 3
       Application.ScreenUpdating = True
    End Sub
    Sub ExpandData(rngData As Range, colSplit As Long, Optional sDelimiter As String = vbLf)
       ' generic routine to expand rows where multiple data items are in one cell separated by a delimiter
       Dim vSplitVals             As Variant
       Dim lValCnt                As Long
       Dim lCntr                  As Long
       Dim n                      As Long
       With rngData
          For n = .Rows.Count To 1 Step -1
             If InStr(.Cells(n, colSplit).Value, sDelimiter) > 0 Then
                vSplitVals = Split(.Cells(n, colSplit).Value, sDelimiter)
                lValCnt = UBound(vSplitVals)
                .Rows(n + 1).Resize(lValCnt).Insert
                .Rows(n + 1).Resize(lValCnt).Value = .Rows(n).Value
                For lCntr = 0 To lValCnt
                   .Cells(n + lCntr, colSplit).Value = vSplitVals(lCntr)
                Next lCntr
             End If
          Next n
       End With
       rngData.EntireRow.AutoFit
    End Sub
    Regards,
    Rory

    Microsoft MVP - Excel

  8. #8
    New Lounger
    Join Date
    Dec 2012
    Posts
    7
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Hi RG,

    Sorry for the late reply. Looks like that works as intended. I will do some more testing. Thank-you very much!

    Greg

  9. #9
    New Lounger
    Join Date
    Dec 2012
    Posts
    7
    Thanks
    0
    Thanked 0 Times in 0 Posts
    I was handed a wrinkle to this issue. The following image shows the issue, with 2 cells now having multiple lines.

    NewLayout.png

    As per the example, the cell values line up with each other, so the supplier and part number are tied together, where they repeat. Is this do-able?

    Thanks.

  10. #10
    5 Star Lounger
    Join Date
    Jan 2004
    Location
    Praha
    Posts
    988
    Thanks
    56
    Thanked 105 Times in 90 Posts
    Just in passing, did Kennet and Johanson really receive 2 each, or was it 1 each making 2 in total ?

  11. #11
    New Lounger
    Join Date
    Dec 2012
    Posts
    7
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Great catch. We were planning on ignoring that column on ingestion into a Bill of Materials Management system. The data is actually a total, so 1 each for a total of 2.

  12. #12
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,433
    Thanks
    371
    Thanked 1,456 Times in 1,325 Posts
    Greg,

    Here is code that should handle the problem:
    Code:
    Option Explicit
    
    Sub ExpandPNs()
    
    ' Routine to automatically expand Part Numbers where multiples have been
    ' entered into a single cell, using Alt-Enter.
    
       Dim vSplitVals  As Variant
       Dim vSplitVals2 As Variant
       Dim lValCnt     As Long
       Dim lValCnt2    As Long
       Dim lCntr       As Long
    
       [A2].Select
       
       Do
         vSplitVals = Split(ActiveCell.Offset(0, 2).Value, Chr(10))
         vSplitVals2 = Split(ActiveCell.Offset(0, 3).Value, Chr(10))
         lValCnt = UBound(vSplitVals)
         lValCnt2 = UBound(vSplitVals2)
           
         If lValCnt2 > lValCnt Then
         
           MsgBox "Row: " & Format(ActiveCell.Row) & " needs manual attention", _
                        vbCritical + vbOKOnly, "Manual Processing Required"
           With ActiveCell.EntireRow.Interior
               .Pattern = xlSolid
               .PatternColorIndex = xlAutomatic
               .Color = 65535
           End With
                            
         Else
           ActiveCell.Offset(0, 2) = vSplitVals(0)
           ActiveCell.Offset(0, 3) = vSplitVals2(0)
    
           If lValCnt > 0 Then
         
             For lCntr = 1 To lValCnt
         
                With ActiveCell
                   .Offset(lCntr, 0).EntireRow.Insert
                   .Offset(lCntr, 0).Value = .Value
                   .Offset(lCntr, 1).Value = .Offset(0, 1).Value
                   .Offset(lCntr, 2).Value = vSplitVals(lCntr)
                   If lValCnt2 > 0 Then
                   .Offset(lCntr, 3).Value = vSplitVals2(lCntr)
                   Else
                   .Offset(lCntr, 3).Value = .Offset(0, 3).Value
                   End If
                   
               End With
                
             Next  'lCntr
         
           End If  'lvalCnt > 1
         
         End If  'lValCnt2 > lValCnt
         
         ActiveCell.Offset(lValCnt + 1, 0).Select
         
       Loop While ActiveCell.Value <> ""
       
       Rows("1:" & ActiveCell.Row).EntireRow.AutoFit
    
    End Sub
    I included code to check if there were more header4's than header3's in which case you get a message, the row is highlighted and processing continues on the next row. There are possibly more error conditions but this should give you a start. Test file attached.
    Attached Files Attached Files
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  13. #13
    New Lounger
    Join Date
    Dec 2012
    Posts
    7
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Hmm. I must be doing something wrong. I changed the code to start in cell G8, the first cell in the table, but when I run it, it simply skips down the list until it finds the first occurrence of a cell that does not have multiple values in it, the throws the "Manual Processing Required" message, without having changed any of the cells above with multiple values. Where did I goof? :-)

    Thanks,

    Greg

  14. #14
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,433
    Thanks
    371
    Thanked 1,456 Times in 1,325 Posts
    Greg,

    I assume that you only changed this line: [A2].Select
    To this: [G8].Select ?

    If that is true then I'd have to see the actual data to figure out what is going wrong. That is there must be something different in your data than the sample data used.
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  15. #15
    New Lounger
    Join Date
    Mar 2014
    Posts
    1
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Great Solution

Tags for this Thread

Posting Permissions

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