Remove Rows from Worksheet - VBA Macro

Hello,

I have the attached spreadsheet with two worksheets. One worksheet (called data) just lists rows of email addresses and the other worksheet (called emails) also lists email addresses. What I would like to be able to do is create a VBA macro which will look at the email addresses on the emails tab (this list will change regularly) and if the email address does not exist in a row on the data tab in either column Email 1 (F) or Email 2 (H) then delete the row - the effect being it will leave only rows where the email (from the emails tab) appears in either column F or H! If possible I don't want the check to be case sensitive - I was thinking of using something like UCASE in the macro or something?

Could someone help me with this macro - I have started but failed at getting it to work.

Regards,

GISVPN
Example-WS.xlsx
gisvpnAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Martin LissOlder than dirtCommented:
Sub emails()
Dim lngLastRow As Long
Dim lngRow As Long
Dim rngFound As Range

Application.ScreenUpdating = False

With Sheets("Data")
    lngLastRow = .UsedRange.Rows.Count
    
    For lngRow = lngLastRow To 2 Step -1
        Set rngFound = Sheets("Emails").Cells.Find(What:=.Cells(lngRow, "F"), After:=ActiveCell, LookIn:=xlValues, LookAt _
            :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
            False, SearchFormat:=False)
        If rngFound Is Nothing Then
            Set rngFound = Sheets("Emails").Cells.Find(What:=.Cells(lngRow, "H"), After:=ActiveCell, LookIn:=xlValues, LookAt _
                :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
                False, SearchFormat:=False)
        End If
        If rngFound Is Nothing Then
            .Cells(lngRow, "F").EntireRow.Delete
        End If
    Next
End With

Application.ScreenUpdating = True

End Sub

Open in new window

0
[ fanpages ]IT Services ConsultantCommented:
...or a proposal with some error handling built-in...

Option Explicit

Private lngErr_Number                                   As Long
Private strErr_Description                              As String
Public Sub Q_28713409()

  Dim blnErr_Ignore                                     As Boolean
  Dim lngRow                                            As Long
  Dim objFind                                           As Range
  Dim objWorksheet_Data                                 As Worksheet
  Dim objWorksheet_Emails                               As Worksheet
  Dim strValue                                          As String
  
  On Error GoTo Err_Q_28713409

  blnErr_Ignore = False

  Set objWorksheet_Data = ThisWorkbook.Worksheets("Data")
  Set objWorksheet_Emails = ThisWorkbook.Worksheets("Emails")
  Set objFind = Nothing
  
  objWorksheet_Emails.Activate
  
  Application.ScreenUpdating = False
  
  For lngRow = Cells(Rows.Count, "A").End(xlUp).Row To 2& Step -1&
  
      DoEvents
      
      strValue = Trim$(objWorksheet_Emails.Cells(lngRow, "A"))
      
      Select Case (True)
      
          Case (Len(strValue) = 0)
          Case (InStr(strValue, "@") = 0)
          
          Case Else
              blnErr_Ignore = True
              
              Set objFind = Nothing
              Set objFind = objWorksheet_Data.Columns("F").Find(What:=strValue, After:=[F2], MatchCase:=False)
              
              If (objFind Is Nothing) Then
                 Set objFind = objWorksheet_Data.Columns("H").Find(What:=strValue, After:=[H2], MatchCase:=False)
              End If ' If (objFind Is Nothing) Then
          
              blnErr_Ignore = False
              
              If (objFind Is Nothing) Then
                 objWorksheet_Emails.Rows(lngRow).Delete
              End If ' If Not (objFind Is Nothing) Then
              
      End Select ' Select Case (True)
      
  Next lngRow ' For lngRow = Cells(Rows.Count, "A").End(xlUp) To 2& Step -1&
  
Exit_Q_28713409:

  On Error Resume Next

  Set objFind = Nothing
  Set objWorksheet_Emails = Nothing
  Set objWorksheet_Data = Nothing

  Application.ScreenUpdating = True

  Exit Sub
  
Err_Q_28713409:

  lngErr_Number = Err.Number
  strErr_Description = Err.Description

  On Error Resume Next

  If (blnErr_Ignore) Then
     On Error GoTo Err_Q_28713409
     Resume Next
  End If ' If (blnErr_Ignore) Then
 
  Application.ScreenUpdating = True
  
  Beep
  MsgBox "Error #" & CStr(lngErr_Number) & _
         vbCrLf & vbLf & _
         strErr_Description, _
         vbExclamation Or vbOKOnly, _
         ThisWorkbook.Name

  Resume Exit_Q_28713409
  
End Sub

Open in new window


(Code above taken from the attached workbook)

PS. I am just preparing an alternate method of achieving the same result.
Q_28713409.xlsm
0
[ fanpages ]IT Services ConsultantCommented:
Here is an alternate approach, that creates an AutoFilter on column [ B ] of the [Emails] worksheet, adds a formula to each row (matching the corresponding value of column [A] to the two applicable columns )[F] & [H]) within the [Data] worksheet), filters column [ B ] of [Emails] on the outcome of the formula (FALSE; i.e. not found), & then deletes every matching row within the Filtered result, before finally removing the AutoFilter, & clearing the contents of column [ B ]...

Public Sub Q_28713409b()

  Dim blnErr_Ignore                                     As Boolean
  Dim objRange                                          As Range
  Dim objWorksheet_Emails                               As Worksheet
  
  On Error GoTo Err_Q_28713409b

  blnErr_Ignore = False

  Set objWorksheet_Emails = ThisWorkbook.Worksheets("Emails")
  
  objWorksheet_Emails.Activate
  
  Application.ScreenUpdating = False
  
  If (ActiveSheet.FilterMode) Then
     ActiveSheet.AutoFilterMode = False
  End If ' If (ActiveSheet.FilterMode) Then
  
  Columns(2).ClearContents
  
  Set objRange = Range([A2], Cells(Rows.Count, "A").End(xlUp))
  
  If objRange.Row > 1& Then
     objRange.Offset(0&, 1).Formula = "=IFERROR(OR(MATCH(A2,Data!F:F,0),MATCH(A2,Data!H:H,0)),FALSE)"
     [B1] = "Filter"
     
     [B1].AutoFilter
     ActiveSheet.Columns(2).AutoFilter Field:=2, Criteria1:="=FALSE"
     
     blnErr_Ignore = True
     Set objRange = Nothing
     Set objRange = Range([A2], Cells(Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeVisible)
     blnErr_Ignore = False
     
     If Not (objRange Is Nothing) Then
        objRange.EntireRow.Delete
     End If ' If Not (objRange Is Nothing) Then
  End If ' If objRange.Row > 1& Then
  
Exit_Q_28713409b:

  On Error Resume Next

  If Not (objWorksheet_Emails Is Nothing) Then
     objWorksheet_Emails.Activate
     
     If (ActiveSheet.FilterMode) Then
        ActiveSheet.AutoFilterMode = False
     End If ' If (ActiveSheet.FilterMode) Then
     
     Columns(2).ClearContents
     
     Set objWorksheet_Emails = Nothing
  End If ' If Not (objWorksheet_Emails Is Nothing) Then
  
  Set objRange = Nothing
  
  Application.ScreenUpdating = True

  Exit Sub
  
Err_Q_28713409b:

  lngErr_Number = Err.Number
  strErr_Description = Err.Description

  On Error Resume Next

  If (blnErr_Ignore) Then
     On Error GoTo Err_Q_28713409b
     Resume Next
  End If ' If (blnErr_Ignore) Then
 
  Application.ScreenUpdating = True
  
  Beep
  MsgBox "Error #" & CStr(lngErr_Number) & _
         vbCrLf & vbLf & _
         strErr_Description, _
         vbExclamation Or vbOKOnly, _
         ThisWorkbook.Name

  Resume Exit_Q_28713409b
  
End Sub

Open in new window


This routine & the one from my previous comment are both within the attached workbook.
Q_28713409b.xlsm
0
Cloud Class® Course: Microsoft Windows 7 Basic

This introductory course to Windows 7 environment will teach you about working with the Windows operating system. You will learn about basic functions including start menu; the desktop; managing files, folders, and libraries.

gisvpnAuthor Commented:
Hi Fanpages - thanks for the post; the example worksheet you posted does not seem to work?

Martin - I will try your code, thanks too for the post.
0
[ fanpages ]IT Services ConsultantCommented:
"Hi Fanpages - thanks for the post; the example worksheet you posted does not seem to work?"

What outcome are you seeing, or what messages are displayed?  The worksheets within both workbooks are the same as you provided.

(I presume you are aware how to execute the code once the workbook is open but, if not, please let me know & I will advise you accordingly).

Regardless of this, the code is posted (for both routines) for you to try in your own workbook.
0
gisvpnAuthor Commented:
Sure I must be running it incorrectly; could you please confirm ?
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Another approach...
Please find the attached workbook and click on the button on Data Sheet to run the code and see if you get the desired output.

Here is the code:
Sub DeleteRows()
Dim dict As Object
Dim sws As Worksheet, dws As Worksheet
Dim cell As Range
Dim i As Long, lr As Long

Application.ScreenUpdating = False

Set sws = Sheets("Emails")
Set dws = Sheets("Data")
lr = dws.Cells(Rows.Count, "F").End(xlUp).Row
Set dict = CreateObject("Scripting.Dictionary")

For Each cell In sws.Range("A2", sws.Range("A" & Rows.Count).End(xlUp))
    If Not dict.exists(cell.Value) Then
        dict.Add cell.Value, Nothing
    End If
Next cell

For i = lr To 2 Step -1
    If Not dict.exists(dws.Cells(i, "F").Value) And Not dict.exists(dws.Cells(i, "H").Value) Then
        Rows(i).Delete
    End If
Next i

Application.ScreenUpdating = True
MsgBox "Rows have been deleted successfully.", vbExclamation, "Done!"
End Sub

Open in new window

Example-WS.xlsm
1

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
[ fanpages ]IT Services ConsultantCommented:
Sure I must be running it incorrectly; could you please confirm ?

Trying to advise you what you may be doing incorrectly, when I do not know what you are doing is going to prove difficult! :)

Have you manually run the code, or did you expect it to happen when you opened the workbook?

Please open the second workbook I posted (in Comment ID: 40974505); "Q_28713409b.xlsm".

This contains the code for the two different approaches I proposed, & also your original worksheets, [Data], & [Emails].  [Emails] is selected when the workbook is opened.

Click to [Enabled Editing], if prompted...

PROTECTED VIEW - Enable Editing
Click to [Enable Content], if prompted...

SECURITY WARNING - Enable Content
Hold down the (left) [ALT] key, keep it pressed down & press the [F8] key, on your keyboard.

Release [F8], then release [ALT].

That is, use [ALT]+[F8] to open the "Macro" window...

Macro Window - Q_28713409
Select either routine ("Q_28713409" as shown in the above image, or "Q_28713409b"), then click the [Run] button.

Nothing will happen initially, as both e-mail addresses you entered originally exist in (both) column [F] &/or column [H] of the [Data] worksheet.

However, if you then add a third entry (on the fourth row) of [Emails], for example...

Data Worksheet Row
...or edit the existing two entries, or add as many new entries to column [A] as desired.

When you repeat the [ALT]+[F8] key combination, select "Q_28713409" or "Q_28713409b" from the list of "Macros", then click the [Run] button again, any e-mails address that do not exist within either column [F] or column [H] of the [Data] worksheet will be removed (as the entire row from [Emails] will be deleted, as you requested).

Hmmm... running "Q_28713409b" now I noticed that it may also remove the heading in row #1 (as the explicit text "Emails" does not exist in either of the designated columns of the [Data] worksheet)!  Whoops.  Obviously too tired at just past midnight when I posted the second approach.

"Q_28713409" works as intended though.  I can adjust "Q_28713409b" if you wish.
0
Martin LissOlder than dirtCommented:
I'm glad I was able to help.

In my profile you'll find links to some articles I've written that may interest you.
Marty - MVP 2009 to 2015, Experts-Exchange Top Expert Visual Basic Classic 2012 to 2014
1
gisvpnAuthor Commented:
Thanks for the help on this one - sktneer - solution spot on thanks.

Fanpages - thanks for the guidance above, I think I worked out why I had not thought it had worked. I believe you have it the wrong way around. You provided a solution whereby it would remove from the emails tab any email address that does not appear on the data tab - however I needed the other way around where any email address on the data tab not appearing on the email tab should be removed from the data tab!

Sorry it was probably the way in which I described it, but the solution provided by sktneer was the one I was needing help with!

Thanks again all!

Regards,
GISVPN
0
[ fanpages ]IT Services ConsultantCommented:
OK, thanks.

If you had mentioned that before closing the thread, I would have been happy to amend what I provided.

Still, we both learned something regarding approaching questions in the future, I hope.
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You're welcome gisvpn! Glad I could help. :)
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.