Hi all,

I have some 500 rows. I want to delete all rows, except row 1, of which col
G is zero or blank while col A shows anything else than a string of which
the first character is S or P.

In other words, I want to keep row 1 and all rows in which col A shows text
starting with S or P and all rows not having zero or blank in col G.

I need the fastest code possible, my do loop takes a lot of time. I thank
you in advance for your assistance.

Jack Sons
The Netherlands

Have you already turned off screen updates and auto calculation? Those are
typically the real time hogs. In general, if none of the work inside the
loop depends on changes made by the loop:
application.calculation=xlmanual
application.screenupdating=false
.... do the work here ...
application.screenupdating=true
application.calculation=xlautomatic



I need the fastest code possible, my do loop takes a lot of time.

Hi Jack,

Try:
'==============
Public Sub Tester001()
Dim rng As Range
Dim rCell As Range
Dim WB As Workbook
Dim SH As Worksheet
Dim delRng As Range
Dim blDelete As Boolean
Dim CalcMode As Long

Set WB = ActiveWorkbook '<<===== CHANGE
Set SH = WB.Sheets("Sheet3") '<<===== CHANGE

Set rng = SH.Range("A2").Resize(SH.UsedRange.Rows.Count - 1)

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

For Each rCell In rng.Cells
blDelete = False
With rCell
If rCell.Offset(0, 6).Value = 0 Then
blDelete = True

ElseIf LCase(Left(.Value, 1)) < "s" _
And LCase(Left(.Value, 1)) < "p" Then
blDelete = True
Else
blDelete = False
End If

If blDelete Then
If delRng Is Nothing Then
Set delRng = rCell
Else
Set delRng = Union(rCell, delRng)
End If
End If
End With
Next rCell

If Not delRng Is Nothing Then
delRng.EntireRow.Delete
End If

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

End Sub
'<<==============

---
Regards,
Norman


"Jack Sons" wrote in message
...
Hi all,

I have some 500 rows. I want to delete all rows, except row 1, of which
col G is zero or blank while col A shows anything else than a string of
which the first character is S or P.

In other words, I want to keep row 1 and all rows in which col A shows
text starting with S or P and all rows not having zero or blank in col G.

I need the fastest code possible, my do loop takes a lot of time. I thank
you in advance for your assistance.

Jack Sons
The Netherlands

Norman,

Thanks for the code. Looks much more intelligent than mine and it is super
fast, but ... it deletes everything except row 1.

I made a few changes (see below) but to no avail. Can you help me out of
this impasse?

Jack.

'==============
Public Sub Tester001()
Dim rng As Range
Dim rCell As Range
Dim WB As Workbook
Dim SH As Worksheet
Dim delRng As Range
Dim blDelete As Boolean
Dim CalcMode As Long

' Set WB = Workbooks("LEERL05") 'ActiveWorkbook '<<===== CHANGE
' Set SH = Workbooks("LEERL05").Sheets("achterstanden") '<<=====
CHANGE

'Set rng =
Workbooks("LEERL05").Sheets("achterstanden").Range ("A2").Resize(Workbooks("LEERL05").Sheets("achters tanden").UsedRange.Rows.Count
- 1)
Set rng = Range("A2").Resize(UsedRange.Rows.Count - 1)

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

For Each rCell In rng.Cells
blDelete = False
With rCell
If rCell.Offset(0, 6).Value = 0 Or rCell.Offset(0, 6).Value = ""
Then
blDelete = True

ElseIf LCase(Left(.Value, 1)) < "S" _
And LCase(Left(.Value, 1)) < "P" Then
blDelete = True
Else
blDelete = False
End If

If blDelete Then
If delRng Is Nothing Then
Set delRng = rCell
Else
Set delRng = Union(rCell, delRng)
End If
End If
End With
Next rCell

If Not delRng Is Nothing Then
delRng.EntireRow.Delete
End If

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

End Sub
'<<==============
"Norman Jones" schreef in bericht
...
Hi Jack,

Try:
'==============
Public Sub Tester001()
Dim rng As Range
Dim rCell As Range
Dim WB As Workbook
Dim SH As Worksheet
Dim delRng As Range
Dim blDelete As Boolean
Dim CalcMode As Long

Set WB = ActiveWorkbook '<<===== CHANGE
Set SH = WB.Sheets("Sheet3") '<<===== CHANGE

Set rng = SH.Range("A2").Resize(SH.UsedRange.Rows.Count - 1)

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

For Each rCell In rng.Cells
blDelete = False
With rCell
If rCell.Offset(0, 6).Value = 0 Then
blDelete = True

ElseIf LCase(Left(.Value, 1)) < "s" _
And LCase(Left(.Value, 1)) < "p" Then
blDelete = True
Else
blDelete = False
End If

If blDelete Then
If delRng Is Nothing Then
Set delRng = rCell
Else
Set delRng = Union(rCell, delRng)
End If
End If
End With
Next rCell

If Not delRng Is Nothing Then
delRng.EntireRow.Delete
End If

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

End Sub
'<<==============

---
Regards,
Norman


"Jack Sons" wrote in message
...
Hi all,

I have some 500 rows. I want to delete all rows, except row 1, of which
col G is zero or blank while col A shows anything else than a string of
which the first character is S or P.

In other words, I want to keep row 1 and all rows in which col A shows
text starting with S or P and all rows not having zero or blank in col G.

I need the fastest code possible, my do loop takes a lot of time. I thank
you in advance for your assistance.

Jack Sons
The Netherlands

Hi Jack,

I think that your problem relates to the changes you have effected.

You changed:

If rCell.Offset(0, 6).Value = 0 Then

to:

If rCell.Offset(0, 6).Value = 0 Or rCell.Offset(0, 6).Value = ""

The addition of the Or condition is unnecessary: an empty cell has a zero
value.

You changed:

ElseIf LCase(Left(.Value, 1)) < "s" _
And LCase(Left(.Value, 1)) < "p" Then

to:

ElseIf LCase(Left(.Value, 1)) < "S" _
And LCase(Left(.Value, 1)) < "P" Then

This change will cause all rows (except for row 1) to be deleted because a
lower case anything can never equate to an upper case S or an upper case P -
or, indeed an upper case anything.

Try, therefore this version of my original code, which is amended only to
insert your workbook and worksheet names.

'==============
Public Sub Tester002()
Dim rng As Range
Dim rCell As Range
Dim WB As Workbook
Dim SH As Worksheet
Dim delRng As Range
Dim blDelete As Boolean
Dim CalcMode As Long

Set WB = Workbooks("LEERL05.xls")
Set SH = WB.Sheets("achterstanden")

Set rng = SH.Range("A2").Resize(SH.UsedRange.Rows.Count - 1)

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

For Each rCell In rng.Cells
blDelete = False
With rCell
If rCell.Offset(0, 6).Value = 0 Then
blDelete = True

ElseIf LCase(Left(.Value, 1)) < "s" _
And LCase(Left(.Value, 1)) < "p" Then
blDelete = True
Else
blDelete = False
End If

If blDelete Then
If delRng Is Nothing Then
Set delRng = rCell
Else
Set delRng = Union(rCell, delRng)
End If
End If
End With
Next rCell

If Not delRng Is Nothing Then
delRng.EntireRow.Delete
End If

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

End Sub
'<<==============

Running this code on my test data, the code ran without problem and deleted
only rows which were both unpopulated in column G and did not have an
initial S or P character in column A. As written, the S and P characters
could be upper or lower case.


---
Regards,
Norman


"Jack Sons" wrote in message
...
Norman,

Thanks for the code. Looks much more intelligent than mine and it is super
fast, but ... it deletes everything except row 1.

I made a few changes (see below) but to no avail. Can you help me out of
this impasse?

Jack.

'==============
Public Sub Tester001()
Dim rng As Range
Dim rCell As Range
Dim WB As Workbook
Dim SH As Worksheet
Dim delRng As Range
Dim blDelete As Boolean
Dim CalcMode As Long

' Set WB = Workbooks("LEERL05") 'ActiveWorkbook '<<===== CHANGE
' Set SH = Workbooks("LEERL05").Sheets("achterstanden") '<<=====
CHANGE

'Set rng =
Workbooks("LEERL05").Sheets("achterstanden").Range ("A2").Resize(Workbooks("LEERL05").Sheets("achters tanden").UsedRange.Rows.Count
- 1)
Set rng = Range("A2").Resize(UsedRange.Rows.Count - 1)

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

For Each rCell In rng.Cells
blDelete = False
With rCell
If rCell.Offset(0, 6).Value = 0 Or rCell.Offset(0, 6).Value =
"" Then
blDelete = True

ElseIf LCase(Left(.Value, 1)) < "S" _
And LCase(Left(.Value, 1)) < "P" Then
blDelete = True
Else
blDelete = False
End If

If blDelete Then
If delRng Is Nothing Then
Set delRng = rCell
Else
Set delRng = Union(rCell, delRng)
End If
End If
End With
Next rCell

If Not delRng Is Nothing Then
delRng.EntireRow.Delete
End If

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

End Sub
'<<==============

Norman,

I understand.

Thank you very much.

Jack.
"Norman Jones" schreef in bericht
...
Hi Jack,

I think that your problem relates to the changes you have effected.

You changed:

If rCell.Offset(0, 6).Value = 0 Then

to:

If rCell.Offset(0, 6).Value = 0 Or rCell.Offset(0, 6).Value = ""

The addition of the Or condition is unnecessary: an empty cell has a zero
value.

You changed:

ElseIf LCase(Left(.Value, 1)) < "s" _
And LCase(Left(.Value, 1)) < "p" Then

to:

ElseIf LCase(Left(.Value, 1)) < "S" _
And LCase(Left(.Value, 1)) < "P" Then

This change will cause all rows (except for row 1) to be deleted because a
lower case anything can never equate to an upper case S or an upper case
P - or, indeed an upper case anything.

Try, therefore this version of my original code, which is amended only to
insert your workbook and worksheet names.

'==============
Public Sub Tester002()
Dim rng As Range
Dim rCell As Range
Dim WB As Workbook
Dim SH As Worksheet
Dim delRng As Range
Dim blDelete As Boolean
Dim CalcMode As Long

Set WB = Workbooks("LEERL05.xls")
Set SH = WB.Sheets("achterstanden")

Set rng = SH.Range("A2").Resize(SH.UsedRange.Rows.Count - 1)

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

For Each rCell In rng.Cells
blDelete = False
With rCell
If rCell.Offset(0, 6).Value = 0 Then
blDelete = True

ElseIf LCase(Left(.Value, 1)) < "s" _
And LCase(Left(.Value, 1)) < "p" Then
blDelete = True
Else
blDelete = False
End If

If blDelete Then
If delRng Is Nothing Then
Set delRng = rCell
Else
Set delRng = Union(rCell, delRng)
End If
End If
End With
Next rCell

If Not delRng Is Nothing Then
delRng.EntireRow.Delete
End If

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

End Sub
'<<==============

Running this code on my test data, the code ran without problem and
deleted only rows which were both unpopulated in column G and did not have
an initial S or P character in column A. As written, the S and P
characters could be upper or lower case.


---
Regards,
Norman


"Jack Sons" wrote in message
...
Norman,

Thanks for the code. Looks much more intelligent than mine and it is
super fast, but ... it deletes everything except row 1.

I made a few changes (see below) but to no avail. Can you help me out of
this impasse?

Jack.

'==============
Public Sub Tester001()
Dim rng As Range
Dim rCell As Range
Dim WB As Workbook
Dim SH As Worksheet
Dim delRng As Range
Dim blDelete As Boolean
Dim CalcMode As Long

' Set WB = Workbooks("LEERL05") 'ActiveWorkbook '<<===== CHANGE
' Set SH = Workbooks("LEERL05").Sheets("achterstanden") '<<=====
CHANGE

'Set rng =
Workbooks("LEERL05").Sheets("achterstanden").Range ("A2").Resize(Workbooks("LEERL05").Sheets("achters tanden").UsedRange.Rows.Count
- 1)
Set rng = Range("A2").Resize(UsedRange.Rows.Count - 1)

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

For Each rCell In rng.Cells
blDelete = False
With rCell
If rCell.Offset(0, 6).Value = 0 Or rCell.Offset(0, 6).Value =
"" Then
blDelete = True

ElseIf LCase(Left(.Value, 1)) < "S" _
And LCase(Left(.Value, 1)) < "P" Then
blDelete = True
Else
blDelete = False
End If

If blDelete Then
If delRng Is Nothing Then
Set delRng = rCell
Else
Set delRng = Union(rCell, delRng)
End If
End If
End With
Next rCell

If Not delRng Is Nothing Then
delRng.EntireRow.Delete
End If

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

End Sub
'<<==============