Sub Insert3Rows()
Application.ScreenUpdating = False
Call DeleteBlankRows
Dim lRow As Long
Dim Rng As Range
Dim WorkRng As Range
On Error Resume Next
Set WorkRng = Application.Selection
lRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
lRow = lRow + 1
Range("A1:A" & lRow).Select
For i = WorkRng.Rows.Count To 2 Step -1
If WorkRng.Cells(i, 1).Value <> WorkRng.Cells(i - 1, 1).Value Then
WorkRng.Cells(i, 1).EntireRow.Insert
WorkRng.Cells(i, 1).EntireRow.Insert
WorkRng.Cells(i, 1).EntireRow.Insert
End If
Next
[A1].Select
Application.ScreenUpdating = True
End Sub
[\CODE]
[CODE]
Sub DeleteBlankRows()
Dim i As Long
Dim lRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet122")
lRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
lRow = lRow + 1
Range("A1:A" & lRow).Select
'We turn off calculation and screenupdating to speed up the macro.
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
'We work backwards because we are deleting rows.
For i = Selection.Rows.Count To 1 Step -1
If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then
Selection.Rows(i).EntireRow.Delete
End If
Next i
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
[\CODE]
Do you think I would be better served posting this in the VBA forum?
