Tom, Thank you very much works like a charm
jer

"Tom Ogilvy" wrote:

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

--
Regards,
Tom Ogilvy



"jer" wrote in message
...

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
--
thanks as always for the help
jer