PDA

View Full Version : [SOLVED] Duplicate Entire row if cell value >15



danuk76
11-20-2015, 06:47 PM
hi guys

I have this macro that works great to copy the entire row down if a cell in I is 20

What I want it to do is Copy the entire row down if a cell in I is GREATER than 20

Lots of searching and head scratching to no avail :think:





Sub abc()

Dim Lrow As Long, i As Long
Dim aRng As Range

Lrow = Cells(Rows.Count, "I").End(xlUp).Row
Set aRng = Range("I1:I" & Lrow)

aRng.Select

With Application

.Calculation = xlCalculationManual
.ScreenUpdating = False

For i = Selection.Rows.Count To 1 Step -1

If InStr(Selection.Rows(i), "20") > 0 Then
Selection.Rows(i).EntireRow.Copy
Selection.Rows(i).EntireRow.Insert Shift:=xlShiftDown
End If

Next i

.Calculation = xlCalculationAutomatic
.ScreenUpdating = True

End With

end sub

SamT
11-20-2015, 07:38 PM
Option Explicit

Sub abc()
Dim i As Long
Dim aRng As Range
Set aRng = Range("I1:I" & Cells(Rows.Count, "I").End(xlUp).Row)

With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

With aRng
For i = .Count To 1 Step -1
If .Cells(i) > 20 Then
.Cells(i).EntireRow.Copy
.Cells(i).EntireRow.Insert Shift:=xlShiftDown
End If
Next i
End With

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub

danuk76
11-20-2015, 07:47 PM
gracias SamT

I was just about to post that myself,,,,,,,,,,,,,,,,no just kidding I had no chance

SamT
11-20-2015, 09:07 PM
Ya gotta be quick to out quick the wizard lizard, buddy :D