Code:Public Sub Duplicate() Dim lastrow As Long Dim numrows As Long Dim i As Long Application.ScreenUpdating = True With ActiveSheet lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row .Range("A1").Resize(lastrow, 2).Copy Worksheets("Sheet2").Range("A1") End With With Worksheets("Sheet2") For i = lastrow To 2 Step -1 If .Cells(i, 2).Value > 1 Then numrows = .Cells(i, "B").Value .Rows(i + 1).Resize(numrows - 1).Insert .Cells(i + 1, "A").Value = .Cells(i, "A").Value .Cells(i, "B").Value = 1 .Cells(i + 1, "B").Value = 2 .Cells(i, "A").Resize(, 2).AutoFill .Cells(i, "A").Resize(numrows, 2) End If Next i .Range("B1").Value = "Case_No" End With Application.ScreenUpdating = False End Sub
Bookmarks