VBA Looping: to delete empty rows within a set of range

[blackorchids2002]

Good Day Masters,

As usual, I'll be needing your help. I am almost done with my code except that I received an error.

To give you an overview, I have a sheet called "Template" which is hidden. Part of the code is to copy the "Template" sheet and rename it to "Schedule A" sheet.

In the Template sheet, it is divided into 3 different categories which I grouped it as well on my code as 3 different ranges. Please see below code for the 3 different sets of ranges. Let say, for set of range under Avaya H&S, I have set a fixed sub-rows for 10 groupings. The same for Support Advantage which has 10 groupings, except for Upgrade Advantage.

'Declaration of Avaya H&S no. Location or Service Type in the PP Summary sheet
'The references within this range will automatically change as rows are inserted within this macro
Set rngAloc = SchedA.Range("B6, B14, B22, B30, B38, B46, B54, B62, B70, B78")

'Declaration of Software Advantage no. Location or Service Type in the PP Summary sheet
'The references within this range will automatically change as rows are inserted within this macro
Set rngBloc = SchedA.Range("B89, B97, B105, B113, B121, B129, B137, B145, B153, B161")

'Declaration of Upgrade Advantage no. Location or Service Type in the PP Summary sheet
'The references within this range will automatically change as rows are inserted within this macro
Set rngCloc = SchedA.Range("B172, B180, B188, B196, B204")

Now the problem is when I tried to delete unneccessary rows of groupings for Avaya (rngAloc) , Support (rngBloc)& Upgrade advantage (rngCloc) ranges, some groupings of rows are deleted and some are not or worst a debug message pop-up when I ran the code.

Below are the codes highlighted in red where I am stucked to aim to delete unneccesary rows. I can share you the file by following this link (https://www.dropbox.com/sh/x2tiiq0i8j4uk1n/0qMmbG0Kol)


Sub ScheduleATemp()

Dim SchedA As Worksheet, PPSheet As Worksheet
Dim rngAloc As Range, AlocCell As Range, rngBloc As Range, BlocCell As Range, rngCloc As Range, ClocCell As Range, k As Long, i As Long, j As Long, RowIns As Long

'Sheets("Schedule A").Delete
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Schedule A").Delete
On Error GoTo 0

Sheets("Template").Visible = True
Sheets("Template").Select
Sheets("Template").Copy Before:=Sheets(3)
ActiveSheet.Name = "Schedule A"
Sheets("Template").Visible = False
Application.DisplayAlerts = True

Set SchedA = Sheets("Schedule A")
Set PPSheet = Sheets("Project Pricing Summary")
PPSheet.Select

'Declaration of Avaya H&S no. Location or Service Type in the PP Summary sheet
'The references within this range will automatically change as rows are inserted within this macro
Set rngAloc = SchedA.Range("B6, B14, B22, B30, B38, B46, B54, B62, B70, B78")

'Declaration of Software Advantage no. Location or Service Type in the PP Summary sheet
'The references within this range will automatically change as rows are inserted within this macro
Set rngBloc = SchedA.Range("B89, B97, B105, B113, B121, B129, B137, B145, B153, B161")

'Declaration of Upgrade Advantage no. Location or Service Type in the PP Summary sheet
'The references within this range will automatically change as rows are inserted within this macro
Set rngCloc = SchedA.Range("B172, B180, B188, B196, B204")


'Avaya H&S codes
For Each AlocCell In rngAloc
k = k + 1
If PPSheet.Cells(5 + k, 5) <> "" Then
PPSheet.Cells(5 + k, 1).FormulaR1C1 = _
"=IF(COUNTIF('Entry Sheet'!C37,'Entry Sheet'!R1C35&RC[4])=0,COUNTIF('Entry Sheet'!C38,'Entry Sheet'!R1C35&RC[4]),COUNTIF('Entry Sheet'!C37,'Entry Sheet'!R1C35&RC[4]))"
RowIns = PPSheet.Cells(5 + k, 1).Value
Application.Goto AlocCell.Offset(3, 0)
AlocCell.Value = PPSheet.Cells(5 + k, 5).Value
If RowIns > 1 Then
AlocCell.Offset(2, 0).EntireRow.Copy
With AlocCell.Offset(3, 0).Resize(RowIns).EntireRow
.Insert Shift:=xlDown
End With

Application.CutCopyMode = False
AlocCell.Offset(RowIns + 2, 0).EntireRow.Select
Range(AlocCell(RowIns + 3, 0), AlocCell.Offset(RowIns + 6, 0)).EntireRow.Select
Selection.Delete Shift:=xlUp
PPSheet.Cells(5 + k, 1).ClearContents
End If
Else
SchedA.Select
AlocCell.EntireRow.Select
Range(AlocCell, AlocCell(8, 0)).EntireRow.Select
Selection.Delete Shift:=xlDown

End If
Next AlocCell
On Error GoTo 0

PPSheet.Select

'Software Advantage codes
For Each BlocCell In rngBloc
i = i + 1
If PPSheet.Cells(38 + i, 5) <> "" Then
PPSheet.Cells(38 + i, 1).FormulaR1C1 = _
"=IF(COUNTIF('Entry Sheet'!C37,'Entry Sheet'!R3C35&RC[4])=0,COUNTIF('Entry Sheet'!C38,'Entry Sheet'!R3C35&RC[4]),COUNTIF('Entry Sheet'!C37,'Entry Sheet'!R3C35&RC[4]))"
RowIns = PPSheet.Cells(38 + i, 1).Value
Application.Goto BlocCell.Offset(3, 0)
BlocCell.Value = PPSheet.Cells(38 + i, 5).Value
If RowIns > 1 Then
BlocCell.Offset(2, 0).EntireRow.Copy
With BlocCell.Offset(3, 0).Resize(RowIns).EntireRow
.Insert Shift:=xlDown
End With

Application.CutCopyMode = False
BlocCell.Offset(RowIns + 2, 0).EntireRow.Select
Range(BlocCell(RowIns + 3, 0), BlocCell.Offset(RowIns + 6, 0)).EntireRow.Select
Selection.Delete Shift:=xlUp
PPSheet.Cells(38 + i, 1).ClearContents
End If
Else
SchedA.Select
BlocCell.EntireRow.Select
Range(BlocCell, BlocCell(8, 0)).EntireRow.Select
Selection.Delete Shift:=xlDown

End If
Next BlocCell

On Error GoTo 0

PPSheet.Select

'Upgrade Advantage codes
For Each ClocCell In rngCloc
j = j + 1
If PPSheet.Cells(22 + j, 5) <> "" Then
PPSheet.Cells(22 + j, 1).FormulaR1C1 = _
"=COUNTIF('Entry Sheet'!C28,'Entry Sheet'!R2C26&RC[4])"
RowIns = PPSheet.Cells(22 + j, 1).Value
Application.Goto ClocCell.Offset(3, 0)
ClocCell.Value = PPSheet.Cells(22 + j, 5).Value
If RowIns > 1 Then
ClocCell.Offset(2, 0).EntireRow.Copy
With ClocCell.Offset(3, 0).Resize(RowIns).EntireRow
.Insert Shift:=xlDown
End With

Application.CutCopyMode = False
ClocCell.Offset(RowIns + 2, 0).EntireRow.Select
Range(ClocCell(RowIns + 3, 0), ClocCell.Offset(RowIns + 6, 0)).EntireRow.Select
Selection.Delete Shift:=xlUp
PPSheet.Cells(22 + j, 1).ClearContents
End If
Else
SchedA.Select
ClocCell.EntireRow.Select
Range(ClocCell, ClocCell(8, 0)).EntireRow.Select
Selection.Delete Shift:=xlDown

End If
Next ClocCell

'final format
'Avaya H&S - to delete unnecessary rows for location or service
For Each AlocCell In rngAloc
If AlocCell = 0 Then
AlocCell.EntireRow.Select
Range(AlocCell, AlocCell(8, 0)).EntireRow.Select
Selection.Delete Shift:=xlDown
End If
Next AlocCell

'2nd loop to delete unnecessary rows for location or service
For Each AlocCell In rngAloc
If AlocCell = 0 Then
AlocCell.EntireRow.Select
Range(AlocCell, AlocCell(8, 0)).EntireRow.Select
Selection.Delete Shift:=xlDown
Else
End If
Next AlocCell

'3rd loop to delete unnecessary rows for location or service
For Each AlocCell In rngAloc
If AlocCell = 0 Then
AlocCell.EntireRow.Select
Range(AlocCell, AlocCell(8, 0)).EntireRow.Select
Selection.Delete Shift:=xlDown
Else
End If
Next AlocCell

'Software Adavantage
For Each BlocCell In rngBloc
If BlocCell = 0 Then
BlocCell.EntireRow.Select
Range(BlocCell, BlocCell(8, 0)).EntireRow.Select
Selection.Delete Shift:=xlDown
Else
End If
Next BlocCell

'2nd loop to delete unnecessary rows for location or service
For Each BlocCell In rngBloc
If BlocCell = 0 Then
BlocCell.EntireRow.Select
Range(BlocCell, BlocCell(8, 0)).EntireRow.Select
Selection.Delete Shift:=xlDown
Else
End If
Next BlocCell

'3rd loop to delete unnecessary rows for location or service
For Each BlocCell In rngBloc
If BlocCell = 0 Then
BlocCell.EntireRow.Select
Range(BlocCell, BlocCell(8, 0)).EntireRow.Select
Selection.Delete Shift:=xlDown
Else
End If
Next BlocCell

'Upgrade Advantage
For Each ClocCell In rngCloc
If ClocCell = 0 Then
ClocCell.EntireRow.Select
Range(ClocCell, ClocCell(8, 0)).EntireRow.Select
Selection.Delete Shift:=xlDown
Else
End If
Next ClocCell

'2nd loop to delete unnecessary rows for location or service
For Each ClocCell In rngCloc
If ClocCell = 0 Then
ClocCell.EntireRow.Select
Range(ClocCell, ClocCell(8, 0)).EntireRow.Select
Selection.Delete Shift:=xlDown
Else
End If
Next ClocCell

'3rd loop to delete unnecessary rows for location or service
For Each ClocCell In rngCloc
On Error GoTo 0
If ClocCell = 0 Then
ClocCell.EntireRow.Select
Range(ClocCell, ClocCell(8, 0)).EntireRow.Select
Selection.Delete Shift:=xlDown
Else
End If
Next ClocCell


Columns("G:G").Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("B2").Select
PPSheet.Select
Range("A1").Select
ActiveWorkbook.Save
End Sub



Many thanks in adavance...

Cheers,
Lhe