Macro or VBA help

ste4en

New Member
Joined
Oct 20, 2006
Messages
16
Trying to turn this

ITEM, QTY, HOURS
Pipe, 6, 12
Flange, 4, 16
Support, 1,2

Into
ITEM, QTY, HOURS
Pipe, 1,2
Pipe, 1,2
Pipe, 1,2
Pipe, 1,2
Pipe, 1,2
Pipe, 1,2
Flange, 1, 4
Flange, 1, 4
Flange, 1, 4
Flange, 1, 4
Support, 1, 2

I can do this with a macro that I write for each quantity - eg for all with qty 6 - add five lines and copy the first line into them and then divide the hours by 6 etc. However I have hundereds of different quantities and wanted to speed up the process. So how can I write a dynamic macro that will adjust the number of lines it deals with based on the qty field, or how else could I achieve this.

Thanks

Ste4en
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.

al_b_cnu

Well-known Member
Joined
Jul 18, 2003
Messages
4,516
Hi, Welcome to the board.

Try this macro:
Code:
Sub xxx()
Dim dblDiv As Double, dblValue As Double
Dim iCount As Integer, iPtr As Integer
Dim lRow As Long
Dim R As Range
Dim sItem As String
Dim vCur() As Variant
Dim wsFr As Worksheet, wsTo As Worksheet

Set wsFr = Sheets("Sheet1")
Set wsTo = Sheets("Sheet2")

wsTo.UsedRange.ClearContents
wsTo.Range("A1:C1").Value = wsFr.Range("A1:C1").Value

For Each R In wsFr.Range("A2:A" & wsFr.Cells(Rows.Count, "A").End(xlUp).Row)
    iCount = Val(R.Offset(0, 1).Value)
    dblDiv = Val(R.Offset(0, 2).Value)
    dblValue = dblDiv / iCount
    ReDim vCur(1 To iCount, 1 To 3)
    sItem = R.Text
    For iPtr = 1 To iCount
        vCur(iPtr, 1) = sItem
        vCur(iPtr, 2) = 1
        vCur(iPtr, 3) = dblValue
    Next iPtr
    If iCount > 0 Then
        lRow = wsTo.Cells(Rows.Count, "A").End(xlUp).Row + 1
        wsTo.Range("A" & lRow & ":C" & lRow + iCount - 1).Value = vCur
    End If
Next R

End Sub

which places the output into sheet 2.

To install:
[Alt-F4], Insert / Module
Then paste above code into code window.
 

al_b_cnu

Well-known Member
Joined
Jul 18, 2003
Messages
4,516
... and this version wont fall over if a zero quantity:
Code:
Sub xxx()
Dim dblDiv As Double, dblValue As Double
Dim iCount As Integer, iPtr As Integer
Dim lRow As Long
Dim R As Range
Dim sItem As String
Dim vCur() As Variant
Dim wsFr As Worksheet, wsTo As Worksheet

Set wsFr = Sheets("Sheet1")
Set wsTo = Sheets("Sheet2")

wsTo.UsedRange.ClearContents
wsTo.Range("A1:C1").Value = wsFr.Range("A1:C1").Value

For Each R In wsFr.Range("A2:A" & wsFr.Cells(Rows.Count, "A").End(xlUp).Row)
    iCount = Val(R.Offset(0, 1).Value)
    If iCount > 0 Then
        dblDiv = Val(R.Offset(0, 2).Value)
        dblValue = dblDiv / iCount
        ReDim vCur(1 To iCount, 1 To 3)
        sItem = R.Text
        For iPtr = 1 To iCount
            vCur(iPtr, 1) = sItem
            vCur(iPtr, 2) = 1
            vCur(iPtr, 3) = dblValue
        Next iPtr
        lRow = wsTo.Cells(Rows.Count, "A").End(xlUp).Row + 1
        wsTo.Range("A" & lRow & ":C" & lRow + iCount - 1).Value = vCur
    End If
Next R

End Sub
 

ste4en

New Member
Joined
Oct 20, 2006
Messages
16
Well one more thing; the example I gave ai a simple form of my spreadsheet. I can adjust the range to provide the additional columns but I can't see how to get the column contents to the new sheet. example how would the code change it there were a 4th column - if you could show how that changes the code I think I can figure the rest out.

ITEM, QTY, HOURS; MATERIAL
Pipe, 6, 12 , STEEL
Flange, 4, 16 , PLASTIC
Support, 1,2 , BRASS

TO GIVE THE RESULT:

Into
ITEM, QTY, HOURS , material
Pipe, 1,2, STEEL
Pipe, 1,2, STEEL
Pipe, 1,2, STEEL
Pipe, 1,2, STEEL
Pipe, 1,2, STEEL
Pipe, 1,2, STEEL
Flange, 1, 4, PLASTIC
Flange, 1, 4 , PLASTIC
Flange, 1, 4 , PLASTIC
Flange, 1, 4 , PLASTIC
Support, 1, 2, BRASS
 

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,300
Office Version
  1. 365
Platform
  1. Windows
Try this.
Code:
Sub Expand()
Dim rng As Range
Dim qty As Long
Dim hrs As Long
Dim NoRows As Long
    Set rng = Range("A2")
    While rng.Value <> ""
        If rng.Offset(, 1) > 1 Then
            NoRows = rng.Offset(, 1) - 1
            rng.Offset(1).Resize(NoRows).EntireRow.Insert
            rng.Copy rng.Offset(1).Resize(NoRows)
            rng.Offset(, 2).Resize(NoRows + 1) = rng.Offset(, 2) / rng.Offset(, 1)
            rng.Offset(, 1).Resize(NoRows + 1) = 1
            rng.Offset(, 3).Copy rng.Offset(1, 3).Resize(NoRows)
            Set rng = rng.Offset(NoRows)
        End If
        Set rng = rng.Offset(1)
    Wend
End Sub
 

Forum statistics

Threads
1,136,269
Messages
5,674,743
Members
419,525
Latest member
helensesc

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
Top