?
Solved

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

Posted on 2012-09-12
6
Medium Priority
?
670 Views
Last Modified: 2012-09-14
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
Comment
Question by:Alex Campbell
  • 3
  • 3
6 Comments
 
LVL 35

Accepted Solution

by:
Norie earned 2000 total points
ID: 38392876
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
 
LVL 1

Author Closing Comment

by:Alex Campbell
ID: 38394326
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
 
LVL 35

Expert Comment

by:Norie
ID: 38394889
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
Restore individual SQL databases with ease

Veeam Explorer for Microsoft SQL Server delivers an easy-to-use, wizard-driven interface for restoring your databases from a backup. No expert SQL background required. Web interface provides a complete view of all available SQL databases to simplify the recovery of lost database

 
LVL 1

Author Comment

by:Alex Campbell
ID: 38394987
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
 
LVL 35

Expert Comment

by:Norie
ID: 38395063
Don't worry about it.

Did the code work?
0
 
LVL 1

Author Comment

by:Alex Campbell
ID: 38398778
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

Featured Post

Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Microsoft Office Picture Manager was included in Office 2003, 2007, and 2010, but not in Office 2013. Users had hopes that it would be in Office 2016/Office 365, but it is not. Fortunately, the same zero-cost technique that works to install it with …
If you need to forecast numbers -- typically for finance -- the Windows and Mac versions of Excel 2016 have a basket of tools to get the job done.
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…
Although Jacob Bernoulli (1654-1705) has been credited as the creator of "Binomial Distribution Table", Gottfried Leibniz (1646-1716) did his dissertation on the subject in 1666; Leibniz you may recall is the co-inventor of "Calculus" and beat Isaac…

862 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question