• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 674
  • Last Modified:

Looking for macro to create new records based on values in a cell

I have a spreadsheet where some of the cells have multiple entries. I would like to be able generate new rows based on the values in that cell until all the multiple entries have been produced.  For example in the graphic below, new rows should be created for the values in column E where there is more than one. For example, if there are four items in a cell that would mean four new rows with all the values for the row repeated, but with the values in column E only occurring one time each. It could be in the same spreadsheet or a different one.

Image of Spreadsheet with multiple values in a cell. SamplePeanutButterProducts2009.xls
0
Alex Campbell
Asked:
Alex Campbell
  • 3
  • 3
1 Solution
 
NorieVBA ExpertCommented:
Try this.
Dim rng As Range
Dim rngLotNos As Range
Dim arrLotNos

    Set rng = Range("A2")
    
    
    While rng.Value <> ""
        arrLotNos = Split(rng.Offset(, 4).Value, ",")
        If UBound(arrLotNos) > 0 Then
            rng.Offset(1).Resize(UBound(arrLotNos)).EntireRow.Insert
       
        rng.Resize(, 7).Copy rng.Resize(UBound(arrLotNos) + 1)
        
        rng.Offset(, 4).Resize(UBound(arrLotNos) + 1) = Application.Transpose(arrLotNos)
         End If
         Set rng = rng.Offset(UBound(arrLotNos) + 1)
        
    Wend

Open in new window

0
 
Alex CampbellAuthor Commented:
Absolutely FANTASTIC.  I will go ahead and give you all the points, but it would be greatly appreciated it if you could add a feature to send the output to a new tab.
0
 
NorieVBA ExpertCommented:
Here you are, though it should probably have been a separate question - the code is different.
Dim wsNew As Worksheet
Dim wsSrc As Worksheet
Dim rngDst As Range
Dim rngSrc As Range
Dim rngLotNos As Range
Dim arrLotNos

    Set wsSrc = Worksheets("Sheet1")
    Set rngSrc = wsSrc.Range("A2")
    Set wsNew = Worksheets.Add
    Set rngDst = wsNew.Range("A2")
    
    ' copy headers
    wsSrc.Range("A1:G1").Copy wsNew.Range("A1")

    While rngSrc.Value <> ""
    
        arrLotNos = Split(rngSrc.Offset(, 4).Value, ",")

        If UBound(arrLotNos) > 0 Then

            rngSrc.Resize(, 7).Copy rngDst.Resize(UBound(arrLotNos) + 1)

            rngDst.Offset(, 4).Resize(UBound(arrLotNos) + 1) = Application.Transpose(arrLotNos)
        Else
            rngSrc.Resize(, 7).Copy rngDst
        End If
        
        Set rngSrc = rngSrc.Offset(1)

        Set rngDst = rngDst.Offset(UBound(arrLotNos) + 1)
    Wend

Open in new window

0
Cloud Class® Course: C++ 11 Fundamentals

This course will introduce you to C++ 11 and teach you about syntax fundamentals.

 
Alex CampbellAuthor Commented:
Sorry, didn't realize it was going to be so different. Is there a way I can give you additional points as a separate question?
0
 
NorieVBA ExpertCommented:
Don't worry about it.

Did the code work?
0
 
Alex CampbellAuthor Commented:
yes, it did. Thanks very much.  Showed to co-worker at US FDA and that was just what she was looking for.  Sample data was from Peanut Recalls

will be posting question to go from the individual records to cells with commas.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Cloud Class® Course: CompTIA Cloud+

The CompTIA Cloud+ Basic training course will teach you about cloud concepts and models, data storage, networking, and network infrastructure.

  • 3
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now