Copy row of cells X times based on number in a column

tominabox1

New Member
Joined
Oct 24, 2014
Messages
6
I am completely new to VB so bear with me please! I sometimes have a spreadsheet with data like this:

QTY Ref Des
1 U5
5 C1,4,8-10
3 R10,23,48
1 L2

And I need to expand those "combined" lists so each "ref des" has its own row like this:

QTY Ref Des
1 U5
1 C1
1 C4
1 C8
... and so on.

There is additional data in the spreadsheet rows, these are just the 2 columns that need to be modified during the operation, the rest can just be duplicated/copied.

Any ideas? Thanks
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
I think the numbers in each row are considered separately from the starting "letter". So C1,4,8-10 means "C" + 1, 4, 8, 9, 10.
 
Upvote 0
I think the numbers in each row are considered separately from the starting "letter". So C1,4,8-10 means "C" + 1, 4, 8, 9, 10.

Yes this, it isn't super important that the macro expands the Ref Des, I can do that by hand, the hard and most time consuming part is copying and pasting the rows per the column of QTY
 
Upvote 0
Perhaps this :-
Results "columns "D:E".
If this is the basic result you want, then I can perhaps then expand the other rows. !!!!!
Code:
[COLOR=Navy]Sub[/COLOR] MG29Oct27
[COLOR=Navy]Dim[/COLOR] Ray [COLOR=Navy]As[/COLOR] Variant, Sp [COLOR=Navy]As[/COLOR] Variant
[COLOR=Navy]Dim[/COLOR] MyRay(), n [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] nn [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] Aph [COLOR=Navy]As[/COLOR] [COLOR=Navy]String,[/COLOR] c [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Set[/COLOR] Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
    [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
        Aph = Left(Dn.Value, 1)
        Ray = Split(Mid(Dn.Value, 2), ",")
        [COLOR=Navy]For[/COLOR] n = 0 To UBound(Ray)
            [COLOR=Navy]If[/COLOR] InStr(Ray(n), "-") > 0 [COLOR=Navy]Then[/COLOR]
                Sp = Split(Ray(n), "-")
                [COLOR=Navy]For[/COLOR] nn = Val(Sp(LBound(Sp))) To Val(Sp(UBound(Sp)))
                    c = c + 1
                    ReDim Preserve MyRay(1 To 2, 1 To c)
                    MyRay(1, c) = 1
                    MyRay(2, c) = Aph & nn
                [COLOR=Navy]Next[/COLOR] nn
            [COLOR=Navy]Else[/COLOR]
                    c = c + 1
                    ReDim Preserve MyRay(1 To 2, 1 To c)
                    MyRay(1, c) = 1
                    MyRay(2, c) = Aph & Ray(n)
            [COLOR=Navy]End[/COLOR] If
        [COLOR=Navy]Next[/COLOR] n
    [COLOR=Navy]Next[/COLOR] Dn
Range("D1").Resize(c, 2) = Application.Transpose(MyRay)
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0
Awesome Mick, that works pretty well but I didn't expect that result exactly. I figured you could copy a whole row and paste it since, there's additional important columns beyond the 2 I posted that need to be copied with each entry. Sorry I didn't mention that before.

I have columns A thru O. Column H is "Ref des" and Column J is "QTY". I also need column B and K copied. The rest of the columns are not really needed.

Thanks for the help!
 
Upvote 0
I went with a crude approach.

Assuming Ref def convention is always starting with a letter, and followed by a number, then perhaps this will work.
Code:
Public Sub ListRefDef()
    Dim rngRefDef       As Excel.Range
    Dim rngOutput       As Excel.Range
    Dim varRefs         As Variant
    Dim lngRefDefItem   As Long
    Dim rngCell         As Excel.Range
    Dim lngResultItem   As Long
    Dim varResults      As Variant: ReDim varResults(1 To 1)
    
    Const strComma      As String = ""","""
    Const strHyphen     As String = """-"""
    Const strColon      As String = """:"""
    
    Set rngRefDef = Sheets("Sheet1").Range("B2:B5") 'this needs to point to the range of Ref Def's (including sheet name)
    Set rngOutput = Sheets("Sheet1").Range("E1") 'you need to change this to where you want your results to be produced
    
    varRefs = Evaluate("index(substitute(substitute(B2:B5," & strComma & "," & strComma & "&left(B2:B5,1))," & strHyphen & "," & strColon & "&left(B2:B5,1)),0,0)")
    
    For lngRefDefItem = LBound(varRefs, 1) To UBound(varRefs, 1)
        For Each rngCell In rngRefDef.Parent.Range(varRefs(lngRefDefItem, 1))
            lngResultItem = lngResultItem + 1
            ReDim Preserve varResults(lngResultItem)
            varResults(lngResultItem) = rngCell.Address(0, 0)
        Next rngCell
    Next lngRefDefItem
    
    varResults(0) = "Results"
    rngOutput.Resize(UBound(varResults), 1).Value = Application.Transpose(varResults)
End Sub

Note the two comments that are pointers to range references that you need to change
 
Upvote 0
I figured you could copy a whole row and paste it since, there's additional important columns beyond the 2 I posted that need to be copied with each entry. Sorry I didn't mention that before.
Like Mick - I didn't either think that this might be the case - so mine won't either produce the desired results.
 
Upvote 0
yeah my bad, I was thinking about how I'd produce it from scratch with my limited understanding of programming. It didn't occur to me that it would be easier to do it by column. This is why you ask the pros! :)

Here's a link to a google doc with an example of the data I'm looking at, the highlighted columns are the important ones I mentioned. It might help visualize the problem better to see the actual data.

https://docs.google.com/spreadsheets/d/1XROowx5USWgtRQvdr4SF8ADPcqPVvef7Zt3DxLBmvZs/edit?usp=sharing
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,557
Messages
6,114,291
Members
448,564
Latest member
ED38

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top