Solved

Delete rows based on a column on another sheet

Posted on 2014-12-04
7
147 Views
Last Modified: 2014-12-04
Hi,

I need VBA solution to delete any row on Sheet1 where there is no match between column D on Sheet1 and column A on Sheet2.

Data will always be a text string and the number of rows on either sheet will vary.

Example attached.

Thanks in advance,

swjtx99
Example.xlsx
0
Comment
Question by:swjtx99
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 4
  • 3
7 Comments
 
LVL 34

Expert Comment

by:Norie
ID: 40481292
Perhaps.
Option Explicit

Sub DeleteRows()
Dim rng As Range
Dim rngNames As Range
Dim Res As Variant
Dim I As Long

    With Sheets("Sheet2")
        Set rngNames = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With

    For I = Sheets("Sheet1").Range("D" & Rows.Count).End(xlUp).Row To 2 Step -1

        Set rng = Sheets("Sheet1").Range("D" & I)

        Res = Application.Match(rng.Value, rngNames, 0)

        If IsError(Res) Then
            rng.EntireRow.Delete xlShiftUp
        End If

    Next I

End Sub

Open in new window

0
 

Author Comment

by:swjtx99
ID: 40481450
Hi,

Thanks for the reply. This appears to work but I haven't been able to confirm because my sheet is 45000 rows and it's been over 20 minutes and it's still going. Is there a more expedient method?

Thanks,
0
 
LVL 34

Expert Comment

by:Norie
ID: 40481473
You could try disabling events, turning off screen updating and setting calculations to manual while the code runs.
Option Explicit

Sub DeleteRows()
Dim rng As Range
Dim rngNames As Range
Dim Res As Variant
Dim I As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    With Sheets("Sheet2")
        Set rngNames = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With

    For I = Sheets("Sheet1").Range("D" & Rows.Count).End(xlUp).Row To 2 Step -1

        Set rng = Sheets("Sheet1").Range("D" & I)

        Res = Application.Match(rng.Value, rngNames, 0)

        If IsError(Res) Then
            rng.EntireRow.Delete xlShiftUp
        End If

    Next I

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
End Sub

Open in new window


Is the data in the attached workbook a 'real' representation of your data?

I ask because there could be other methods to speed things, eg using arrays, but they would be dependent on the actual data.
0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

Author Comment

by:swjtx99
ID: 40481529
Hi,

Yes it is an accurate representation of the format. I have a few more actual "owners" and as stated my actual sheet is 45000 rows and more columns but it's doing the same thing which is comparing owners and if they don't exist, I need to delete the row. I just cut it down to 500 and inserted:

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

and it still took about 30 seconds to run. I have an i7 8GB and nothing else running. Would an array method be faster?

Thanks for your help,

swjtx99
but it still took
0
 

Author Comment

by:swjtx99
ID: 40481539
Hi,

Might help if I mention there are 17 columns, A-Q.

Thanks,

swjtx99
0
 
LVL 34

Accepted Solution

by:
Norie earned 500 total points
ID: 40481589
Strange, I tried the code on approx 45000 rows and it seemed quite speedy.

Anyway, perhaps doing the deletion in one go might help speed things up.
Option Explicit



Sub DeleteRows()
Dim rng As Range
Dim rngNames As Range
Dim rngDel As Range
Dim Res As Variant
Dim I As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    With Sheets("Sheet2")
        Set rngNames = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With

    For I = Sheets("Sheet1").Range("D" & Rows.Count).End(xlUp).Row To 2 Step -1

        Set rng = Sheets("Sheet1").Range("D" & I)

        Res = Application.Match(rng.Value, rngNames, 0)

        If IsError(Res) Then
            If rngDel Is Nothing Then
                Set rngDel = rng.EntireRow
            Else
                Set rngDel = Union(rngDel, rng.EntireRow)
            End If
        End If

    Next I

    If Not rngDel Is Nothing Then
        rngDel.Delete
    End If
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
End Sub

Open in new window

0
 

Author Closing Comment

by:swjtx99
ID: 40481735
Hi imnorie,

Thanks, Excellent and very fast.

Regards,

swjtx99
0

Featured Post

Enroll in June's Course of the Month

June’s Course of the Month is now available! Experts Exchange’s Premium Members, Team Accounts, and Qualified Experts have access to a complimentary course each month as part of their membership—an extra way to sharpen your skills and increase training.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Excel can be a tricky bit of software to get your head around. Whilst you’ll be able to eventually get to grips with the basic understanding of how to get by, there are a few Excel tips that not everybody will even know about let alone know how to d…
How to get Spreadsheet Compare 2016 working with the 64 bit version of Office 2016
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.

728 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question