loops ...

[Guest]

Some help please. I have a workbook with 2 worksheets

sheet 1
a b c d e
1 3/12/2004 3 500 25 543
2 3/13/2004 3 501 26 544
3 3/17/2004 4 505 30 548
4 3/18/2004 5 506 31 549
5 3/18/2004 5 506 31 549
6 3/19/2004 6 507 32 550
7 3/20/2004 7 508 33 551

sheet 2
a b c c
1 3/12/2025 3 6000 4
2 3/12/2025 4 8000 3
3 3/12/2025 5 20000 1
4 3/12/2025 6 50000 3
5 3/12/2025 7 23000 4


What I am attempting to do is for every instance
in sheet 1 where the value in column b is equal to the value
in sheet 2 column b to copy and insert the range in sheet 1
as many times as the value in sheet 2 column c. for instance
sheet 1 row 2 will be copied and inserted 4 times, row 2 - 4 times
row 3 - 3 times, row 5 not copied

The result should look like

3/12/2004 3 500 25 543
3/12/2004 3 500 25 543
3/12/2004 3 500 25 543
3/12/2004 3 500 25 543
3/12/2004 3 500 25 543
3/13/2004 3 501 26 544
3/13/2004 3 501 26 544
3/13/2004 3 501 26 544
3/13/2004 3 501 26 544
3/13/2004 3 501 26 544
3/17/2004 4 505 30 548
3/17/2004 4 505 30 548
3/17/2004 4 505 30 548
3/17/2004 4 505 30 548

I have attempted the following which does not work so I am looking for any
help/suggestions

Dim cell As Range, i As Integer, cell1 As Range, j As Integer
Set cell = ActiveWorkbook.Worksheets("Sheet2").Cells(2, 2)
Set cell1 = ActiveWorkbook.Worksheets("Sheet1").Cells(2, 2)

i = cell.Offset(0, 2)

Do Until IsEmpty(cell.Value)
Do While cell = cell1
If cell > 1 Then
For j = 1 To i
Range(cell1.Offset(0, -1), cell1.Offset(0, 3)).Select
Selection.Copy
Selection.Insert Shift:=xlDown
Next j
Application.CutCopyMode = False
End If
Set cell = cell.Offset(1, 0)
Loop
Set cell1 = cell1.Offset(1, 0)
Loop

 

[Tom Ogilvy]

Sub ABC()
Dim cell As Range, i As Long, cell1 As Range
Dim lastrow As Long, sh1 As Worksheet
Set cell = ActiveWorkbook.Worksheets("Sheet2").Cells(1, 2)
Set sh1 = ActiveWorkbook.Worksheets("Sheet1")
Do Until IsEmpty(cell.Value)
lastrow = sh1.Cells(Rows.Count, 2).End(xlUp).Row
For i = lastrow To 1 Step -1
Set cell1 = sh1.Cells(i, 2)
If cell1 = cell And cell.Offset(0, 2) > 1 Then
cell1.Offset(1, 0).Resize(cell.Offset(0, 2) _
, 1).EntireRow.Insert
cell1.Offset(0, -1).Resize(1, 5).Copy _
cell1.Offset(1, -1).Resize(cell.Offset(0, 2), 5)
End If
Next i
Set cell = cell.Offset(1, 0)
Loop
End Sub

 

[Bob Phillips]

Sub Test()
Dim cLastRow As Long
Dim i As Long
Dim irow As Long
Dim ws As Worksheet

cLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set ws = Worksheets("Sheet2")
For i = cLastRow To 1 Step -1
With Worksheets("Sheet1")
On Error Resume Next
irow = Application.Match(.Cells(i, "B").Value, _
ws.Range("B:B"), 0)
On Error GoTo 0
If irow > 0 Then
If ws.Cells(irow, "D").Value > 1 Then
.Cells(i + 1, 1).Resize(ws.Cells(irow, "D").Value - 1) _
.EntireRow.Insert
.Cells(i, 1).EntireRow.Copy Destination:= _
.Cells(i, 1).Resize(ws.Cells(irow, "D").Value)
End If
End If
End With
Next i

End Sub


--

HTH

RP
(remove nothere from the email address if mailing direct)

 

[Guest]

Bob, not to be out done works just as well thank you very much
jer

Sub Test()
Dim cLastRow As Long
Dim i As Long
Dim irow As Long
Dim ws As Worksheet

cLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set ws = Worksheets("Sheet2")
For i = cLastRow To 1 Step -1
With Worksheets("Sheet1")
On Error Resume Next
irow = Application.Match(.Cells(i, "B").Value, _
ws.Range("B:B"), 0)
On Error GoTo 0
If irow > 0 Then
If ws.Cells(irow, "D").Value > 1 Then
.Cells(i + 1, 1).Resize(ws.Cells(irow, "D").Value - 1) _
.EntireRow.Insert
.Cells(i, 1).EntireRow.Copy Destination:= _
.Cells(i, 1).Resize(ws.Cells(irow, "D").Value)
End If
End If
End With
Next i

End Sub


--

HTH

RP
(remove nothere from the email address if mailing direct)

 

[Guest]

Tom, Thank you very much works like a charm
jer

Sub ABC()
Dim cell As Range, i As Long, cell1 As Range
Dim lastrow As Long, sh1 As Worksheet
Set cell = ActiveWorkbook.Worksheets("Sheet2").Cells(1, 2)
Set sh1 = ActiveWorkbook.Worksheets("Sheet1")
Do Until IsEmpty(cell.Value)
lastrow = sh1.Cells(Rows.Count, 2).End(xlUp).Row
For i = lastrow To 1 Step -1
Set cell1 = sh1.Cells(i, 2)
If cell1 = cell And cell.Offset(0, 2) > 1 Then
cell1.Offset(1, 0).Resize(cell.Offset(0, 2) _
, 1).EntireRow.Insert
cell1.Offset(0, -1).Resize(1, 5).Copy _
cell1.Offset(1, -1).Resize(cell.Offset(0, 2), 5)
End If
Next i
Set cell = cell.Offset(1, 0)
Loop
End Sub