Don't add to range if row already exists

[sbitaxi]

Hi -

I'm using the following code in several places. Initially I had
simplified things by letting the Rng values pile up before passing the
Delete statement. Unfortunately, I realized that the various searches
I used occasionally came up with the same row for a different search
criteria. When I ran the delete, it deleted all the rows in the range,
but if a row appeared several times, it deleted valid rows as well.

This was originally a filter, but I thought performing one delete
rather than many would be better.

Thoughts?


Steven

Set FoundCell = SrcHdrRng.Find(What:="Event ID")

For Each MyCell In Range(FoundCell.Address, Cells(SrcLast,
FoundCell.Column).Address)

If MyCell.Value = "Tribute" Then
If Rng Is Nothing Then
Set Rng = Rows(MyCell.Row & ":" &
MyCell.Row)
Else: Set Rng = Union(Rng,
Rows(MyCell.Row & ":" & MyCell.Row))
End If
End If
Next
If Not Rng Is Nothing Then
Rng.Delete
End If
Set Rng = Nothing

 

[Héctor Miguel]

hi, Steven !

try with the following approach:

For Each MyCell In Range(FoundCell.Address, Cells(SrcLast, FoundCell.Column).Address)
If MyCell.Value = "Tribute" Then
Set Rng = Union(Iif(Rng Is Nothing, MyCell, Rng), MyCell)
End If
Next
If Not Rng Is Nothing Then Rng.EntireRow.Delete: Set Rng = Nothing

hth,
hector.

__ OP __

 

[Jim Thomlinson]

Not really following your problem. The code you posted looks for a specific
event ID. It then search all of the cell in that column for the word Tribute.
Everywhere that tribute is found is added to a single large range which you
delete at the end... What is going on that it is deleting rows that you don't
intend to delete. Are there rows with tribute that you do not want to
delete??? Perhaps a better explanation of what you are up to, especially the
criteria for rows that you want to delete.

FYI if you are only deleting a few rows then individual deletes is not a big
deal but when you have to do a lot of deletes there is a distinct perfomance
improvement by doing a single large delete.

 

[sbitaxi]

Hello Héctor!

More elegant code from you, thank you!

If I were to run 3 or 4 blocks of this code, would it be possible to
prevent rows from being duplicated in the Rng? Here is what I have,
but I'd like to run the Delete line once for all of them without
capturing the same row in Rng more than once.

Set FoundCell = SrcHdrRng.Find(What:="Registration Fee")

For Each MyCell In Range(FoundCell.Address, Cells(SrcLast,
FoundCell.Column).Address)
Select Case MyCell.Value
Case "NotApplicable", "Waived"
If MyCell.Offset(0, 1).Value = 0 Then
If Intersect(Rows(MyCell.Row),
Columns(PaymentAmt.Column)).Value = 0 Then
Set Rng = Union(IIf(Rng Is Nothing,
MyCell, Rng), MyCell)
End If
End If

Case "Cancelled"
If MyCell.Offset(0, 1).Value = 0 Then
Set Rng = Union(IIf(Rng Is Nothing,
MyCell, Rng), MyCell)
End If
Case Else
End Select
Next

If Not Rng Is Nothing Then Rng.EntireRow.Delete: Set Rng =
Nothing

'* Removes tribute records
Set FoundCell = SrcHdrRng.Find(What:="Event ID")

For Each MyCell In Range(FoundCell.Address, Cells(SrcLast,
FoundCell.Column).Address)
If MyCell.Value = "Tribute" Then
Set Rng = Union(IIf(Rng Is Nothing, MyCell, Rng),
MyCell)
End If
Next
If Not Rng Is Nothing Then Rng.EntireRow.Delete: Set Rng =
Nothing

Set FoundCell = SrcHdrRng.Find(What:="DonationStatus")

For Each MyCell In Range(FoundCell.Address, Cells(SrcLast,
FoundCell.Column).Address)

If MyCell.Value = "CashPending" Then
If Intersect(Rows(MyCell.Row),
Columns(PaymentAmt.Column)).Value = 0 Then
Set Rng = Union(IIf(Rng Is Nothing,
MyCell, Rng), MyCell)
End If
End If
Next
If Not Rng Is Nothing Then Rng.EntireRow.Delete: Set Rng =
Nothing


Regards,

Steven

 

[sbitaxi]

Hi Jim,

The goal, as you put it, it for one single delete.

I use those lines of code to delete ranges based on different
criteria. In the one above, it looks for the word Tribute in the range
of the column header Event ID.

In another instance I use the code to search for the text "Cash
Pending" under the column header Donation Status

In yet another instance I search for the text "Waived" or "Cancelled"
under the column header Registration Fee

It is entirely possible that one record (row of data) could meet
several of those criteria. Tribute/Cash Pending/Waived could all be in
the same row. Let's call that row 3, to help with the example. If I
use the delete code once, I would have Rng = 3, 3, 3... etc.

If I ran the delete at that point, row 3 would be deleted 3 times, 2
of those times may very well be valid records because as Excel
deletes, it moves the other rows up to fill the hole.

I'd like to perform the delete once, but prevent ranges from being
duplicated in Rng.

Hopefully this makes it a little more clear.


Steven

 

[Jim Thomlinson]

The reason that I have a problem with that is that unioning a range to itself
gets you the same range as you started with... Try this...

Sub test()
Dim rng As Range

Set rng = Range("A1")
Set rng = Union(rng, Range("C1"))
rng.Select
MsgBox rng.Address
Set rng = Union(rng, Range("C1"))
rng.Select
MsgBox rng.Address
Set rng = Union(rng, Range("C11"))
rng.Select
MsgBox rng.Address

End Sub

Note that the C1 address only shows up once... If I were to run
rng.entirecolumn.delete
I would only be deleting column C once...

 

[Dave Peterson]

Instead of building a string of addresses that represent your cells/rows that
should be deleted, you can create a range of cells that does the same thing.

And using a range will avoid any problems with the length of the address
string. (I think you'd have trouble once you hit 255 characters for that
address.)

Say you have a range that's built this way:

dim delrng as range
...

if delrng is nothing then
set delrng = mycell
else
set delrng = union(delrng, mycell)
end if

======
You're still subject to errors if you use this:
delrng.entirerow.delete

But you could use:

intersect(delrng.entirerow, somesheet.columns(1)).entirerow.delete

========
I wasn't sure how you were going to make it easy to update when add headers and
words that should be processed.

I tried a couple of things and came up with an array of arrays.

It consists of the header word and the word in that column. Yep, you could use
the same header word lots of times:

HeaderAndWords = Array(Array("Event ID", "Tribute"), _
Array("Donation status", "Cash pending"), _
Array("Registration fee", "waived"), _
Array("Registration fee", "cancelled"))

===========
This seemed to work ok for me:

Option Explicit
Sub testme()

Dim wks As Worksheet

Dim HeaderAndWords As Variant
Dim hCtr As Long

Dim FoundCell As Range
Dim FirstAddress As String
Dim HeaderCol As Long

Dim DelRng As Range

Set wks = Worksheets("Sheet1")

'first element is the header
'second element is the word to find
'could be multiple arrays--like with "registration fee"
HeaderAndWords = Array(Array("Event ID", "Tribute"), _
Array("Donation status", "Cash pending"), _
Array("Registration fee", "waived"), _
Array("Registration fee", "cancelled"))

With wks
For hCtr = LBound(HeaderAndWords, 1) To UBound(HeaderAndWords, 1)
With .Rows(1) 'the header row
Set FoundCell = .Cells.Find(What:=HeaderAndWords(hCtr)(0), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
End With

If FoundCell Is Nothing Then
MsgBox "Header: " & HeaderAndWords(hCtr)(0) & " wasn't found!"
Else
HeaderCol = FoundCell.Column
FirstAddress = ""
With .Columns(HeaderCol)
Set FoundCell = .Cells(1)
Do
Set FoundCell = .Find(What:=HeaderAndWords(hCtr)(1), _
After:=FoundCell, _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)

If FoundCell Is Nothing Then
'do nothing, it wasn't found
Exit Do
End If

If FirstAddress = "" Then
FirstAddress = FoundCell.Address
Else
If FirstAddress = FoundCell.Address Then
'at the top and starting through the column
'again, so get out
Exit Do
End If
End If

If DelRng Is Nothing Then
Set DelRng = FoundCell
Else
Set DelRng = Union(DelRng, FoundCell)
End If
Loop
End With
End If
Next hCtr


If DelRng Is Nothing Then
MsgBox "No rows to delete!"
Else
Intersect(DelRng.EntireRow, .Columns(1)).EntireRow.Select 'Delete
End If

End With

End Sub

I left the .select at the end--just so you could double check before you trust
it.

 

[Héctor Miguel]

hi, Steven !

If I were to run 3 or 4 blocks of this code, would it be possible to prevent rows from being duplicated in the Rng?
Here is what I have, but I'd like to run the Delete line once for all of them without capturing the same row in Rng more than once.

(please, excuse me) the following proposal is NOT tested ("made @ pure feeling") so,
if any failure... would you please comment ?
and... don't forget to test over a copy of your data

regards,
hector.

' add new variables ... '
Dim nRow As Long, ColRF As Byte, ColEID As Byte, ColDS As Byte, ToDelete As Boolean
ColRF = SrcHdrRng.Find(What:="Registration Fee").Column
ColEID = SrcHdrRng.Find(What:="Event ID").Column
ColDS = SrcHdrRng.Find(What:="DonationStatus").Column
For nRow = 2 To SrcLast
With Cells(nRow, "a")
If .Offset(, ColRF - 1) = "NotApplicable" Or .Offset(, ColRF - 1) = "Waived" _
And .Offset(, ColRF) = 0 And .Offset(, PaymentAmt.Column - 1) = 0 Then
ToDelete = True
ElseIf .Offset(, ColRF - 1) = "Cancelled" And .Offset(, ColRF) = 0 Then
ToDelete = True
ElseIf .Offset(, ColEID - 1) = "Tribute" Then
ToDelete = True
ElseIf .Offset(, ColDS - 1) = "CashPending" And .Offset(, PaymentAmt.Column - 1) = 0 Then
ToDelete = True
End If
If ToDelete Then Set Rng = _
Union(IIf(Rng Is Nothing, Range(.Address), Rng), Range(.Address)): ToDelete = False
End With
Next
If Not Rng Is Nothing Then Rng.EntireRow.Delete: Set Rng = Nothing

__ OP __
__ the exposed code __
Set FoundCell = SrcHdrRng.Find(What:="Registration Fee")

For Each MyCell In Range(FoundCell.Address, Cells(SrcLast, FoundCell.Column).Address)
Select Case MyCell.Value
Case "NotApplicable", "Waived"
If MyCell.Offset(0, 1).Value = 0 Then
If Intersect(Rows(MyCell.Row), Columns(PaymentAmt.Column)).Value = 0 Then
Set Rng = Union(IIf(Rng Is Nothing, MyCell, Rng), MyCell)
End If
End If

Case "Cancelled"
If MyCell.Offset(0, 1).Value = 0 Then
Set Rng = Union(IIf(Rng Is Nothing, MyCell, Rng), MyCell)
End If
Case Else
End Select
Next

If Not Rng Is Nothing Then Rng.EntireRow.Delete: Set Rng = Nothing

'* Removes tribute records
Set FoundCell = SrcHdrRng.Find(What:="Event ID")

For Each MyCell In Range(FoundCell.Address, Cells(SrcLast, FoundCell.Column).Address)
If MyCell.Value = "Tribute" Then
Set Rng = Union(IIf(Rng Is Nothing, MyCell, Rng), MyCell)
End If
Next
If Not Rng Is Nothing Then Rng.EntireRow.Delete: Set Rng = Nothing

Set FoundCell = SrcHdrRng.Find(What:="DonationStatus")

For Each MyCell In Range(FoundCell.Address, Cells(SrcLast, FoundCell.Column).Address)

If MyCell.Value = "CashPending" Then
If Intersect(Rows(MyCell.Row), Columns(PaymentAmt.Column)).Value = 0 Then
Set Rng = Union(IIf(Rng Is Nothing, MyCell, Rng), MyCell)
End If
End If
Next
If Not Rng Is Nothing Then Rng.EntireRow.Delete: Set Rng = Nothing

Regards,

Steven

 

[Dave Peterson]

This would be better:

But you could use:

intersect(delrng.entirerow, delrng.parent.columns(1)).entirerow.delete

Than:

intersect(delrng.entirerow, somesheet.columns(1)).entirerow.delete

Fewer things to change...

 

[sbitaxi]

The reason that I have a problem with that is that unioning a range to itself
gets you the same range as you started with... Try this...

Sub test()
Dim rng As Range

Set rng = Range("A1")
Set rng = Union(rng, Range("C1"))
rng.Select
MsgBox rng.Address
Set rng = Union(rng, Range("C1"))
rng.Select
MsgBox rng.Address
Set rng = Union(rng, Range("C11"))
rng.Select
MsgBox rng.Address

End Sub

Note that the C1 address only shows up once... If I were to run
rng.entirecolumn.delete
I would only be deleting column C once...

Well, not sure what to say Jim. my theory comes from trying it and
ending up with fewer rows than I should have - trying to delete all at
once that is, I haven't toyed with your coded yet. That's the trouble
with having a Mac at home and a PC at work.

It makes complete sense, but I think the issue comes from ranges in
the same row, different columns. The address is going to show up
several times in the Rng variable I suspect. Tribute found in B5,
Waived in H5 and something else in Q5. A Rng.Delete.EntireRow would
delete row 5 three times, wouldn't it? Once for B5, for H5 and finally
for Q5?

In your example, if C1, C5 and C200 were to end up in the range and we
used rng.entirecolumn.delete, I'd suspect there would truly be overlap
and 3 columns removed. Unless it is not done sequentially - instead
each of the ranges selected at once, then the columns deleted... Not
sure. What do you think?


S

 

[sbitaxi]

'first element is the header
'second element is the word to find
'could be multiple arrays--like with "registration fee"
HeaderAndWords = Array(Array("Event ID", "Tribute"), _
Array("Donation status", "Cash pending"), _
Array("Registration fee", "waived"), _
Array("Registration fee", "cancelled"))

How does VBA differentiate between the header and the word to find?
I'm not sure I understand how LBound and UBound relate to these
arrays. Thinking it through -

LBound is the header, UBound is the "word to find", correct? Since
each array only has two values, hCtr will only have two iterations of
the For/Next, one for each value in each array, although the find may
located many rows.

What does the zero do in this line? Wait, that's the LBound value, so
it finds the Header cell and can be declared as the header that way,
while the 1 later calls the UBound value to find the "word to find."

Set FoundCell = .Cells.Find(What:=HeaderAndWords(hCtr)(0)

Some of my Finds/Deletes require further verification on values - If
the Registration Fee is Waived, but there is a payment recorded in the
payment column, then we need to keep this record. Would it be possible
to have a third value in the array which is the equation?
So the array would look something like -

Array("Registration fee", "cancelled", "If Intersect(Rows(MyCell.Row),
Columns(PaymentAmt.Column)).Value = 0 Then")

How can I convert that to a usable If statement rather than it being
stored as text? Would that be UBound(HeaderAndWords, 2) to retrieve
it?

In order to call that statement, is it possible to verify in the array
if there is a 2? Essentially -
if HCtr = LBound(HandW, 1) to UBound(HaW, 2) Then
UBound(HaW, 2)
------> insert delete range lines

In fact, I think most of my criteria has a second validation step
before the range gets added to the DelRng.

With wks
For hCtr = LBound(HeaderAndWords, 1) To UBound(HeaderAndWords, 1)
With .Rows(1) 'the header row
Set FoundCell = .Cells.Find(What:=HeaderAndWords(hCtr)(0), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
End With

So this line tells Excel to delete the entire row, but for only one
of the columns?

Intersect(DelRng.EntireRow, .Columns(1)).EntireRow.Select 'Delete

Thank you Dave, this is a crash course in VBA and I know I have not
even scratched the surface.

 

[sbitaxi]

Hi Dave/Jim/Héctor:

I'm spending my day analyzing the data to get a clear sense of what
records are being deleted. I configured my macro to move all the
deleted ranges to a separate worksheet so I at least kept the records
to examine. I stuck with deleting the records in small chunks rather
than all at once.

I did a brief test of both methods - at once and in chunks, and ended
up with different numbers of records. At first glance it was 634
records remaining from 1950 when deleted in chunks, and 644 when
deleted at once. Further analysis (Record ID matching) revealed that
there were 359 records difference between the results, although the
total number was only different by 10 records. I'm not sure what
records are being kept and which are being delete.

I'll report back and let you know what I determine.


Thank you for your help so far.


Steven

 

[Dave Peterson]

I used .select in my suggestion so that you could double check what rows would
be removed.

You may want to look at that selection when checking.

 

[sbitaxi]

I used .select in my suggestion so that you could double check what rows would
be removed.

You may want to look at that selection when checking.

You did, and I admit I didn't try your code yet. I'm trying to
understand what is happening in the code I am using and how the slight
change of deleting the records together rather than in small chunks is
making a difference. Select would give me a visual, but I wanted to
isolate the data further - so I moved it to a separate worksheet. I
did that for both versions of the code.

Though, now that I have your further advisement, I am going to try it
again using your code.

When the ranges are union'd into the DelRng it seems to resize the
ranges to encompass the new rows. If rows 19, 20 and 21 are each
selected through the process, it will change that to a range 19:21. It
doesn't seem to duplicate as I feared it was, but is instead doing
something different. What I am trying to understand is why there are
359 records that do not appear on both lists. 359 appear on the Chunk
list, but don't appear on the AtOnce list, and equally so the other
way around because they have nearly the same number of rows. Something
bizarre is happening.

I appreciate your help, but until I understand why those records are
not matching, I cannot rely on the code as it stands.


Steven

 

[Dave Peterson]

When I'd checking this kind of thing, I'll use a helper column and put some
formula that will evaluate to "delete" or "keep" based on the rules I'm using.

Since I'm doing it manually, I'll know the columns that I want to check:

=if(or(a2="Tribute",e2="Cash Pending",g2="waived",g2="cancelled"),
"Delete","keep")

Then I'll drag that formula down and apply data|filter|autofilter to see if my
count is right.

And after I do the code (with .select), I can see which rows are selected that
shouldn't be--or which rows are not selected when they should be.

 

[sbitaxi]

Hello Dave/Jim/Héctor,

After much fussing, I can up with a solution combining many of your
suggestions. The following is my code. It stores the records I have
removed, it does not remove good records, as it deletes in chunks. It
just does it more efficiently than I was doing it before. Thank you
again for all your input, I'd have never come up with a solution like
this without your thoughts and experience.

Regards,

Steven

On Error GoTo ErrorHandler

FiltFields = Array(Array("Event ID", "=*Tribute*", "", "Tribute"), _
Array("PaymentStatus", "<>Succeeded", "",
"FailedPayments"), _
Array("Trans Type", "=*Tribute*", "",
"Tribute2"), _
Array("Reg Fee", "=Waived", "=Cancelled",
"Waived_Cancelled"))

For FltFlds = LBound(FiltFields, 1) To UBound(FiltFields, 1)
Set FoundCell = SrcHdrRng.Find(What:=FiltFields(FltFlds)(0), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)

Call WSFilt(SrcWS, SrcEntRng, SrcRng, FiltFields(FltFlds)(1), _
FiltFields(FltFlds)(2), FoundCell.Column,
FiltFields(FltFlds)(3))

Next FltFlds

Public Sub WSFilt(ByVal SourceWS As Worksheet, _
ByVal FiltRng As Range, _
ByVal SourceRng As Range, _
ByVal Crit1 As String, _
ByVal Crit2 As String, _
ByVal FField As Long, _
ByVal ThisWSNm As String)

Dim ThisWS As Worksheet
Dim DelRng As Range

' If there are no values found, go to E: and remove the AutoFilter
On Error GoTo E

FiltRng.AutoFilter Field:=FField, Criteria1:=Crit1, Operator:=xlOr, _
Criteria2:=Crit2
Set DelRng = Union(IIf(DelRng Is Nothing, _
SourceRng.Cells.SpecialCells(xlVisible), DelRng),
_
SourceRng.Cells.SpecialCells(xlVisible))

If Not DelRng Is Nothing Then
Set ThisWS = Worksheets.Add
ThisWS.Name = ThisWSNm

SourceWS.Activate

' Copies Header Row
SourceWS.Range("1:1").Copy Destination:=ThisWS.Range("A1")

' Copies filtered data to ThisWS and deletes it from SourceWS
DelRng.EntireRow.Copy Destination:=ThisWS.Range("A2"): _
DelRng.EntireRow.Delete: Set DelRng = Nothing

End If
E:
SourceWS.AutoFilterMode = False

End Sub