Go Premium for a chance to win a PS4. Enter to Win

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 154
  • Last Modified:

Delete rows based on a column on another sheet

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
swjtx99
Asked:
swjtx99
  • 4
  • 3
1 Solution
 
NorieCommented:
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
 
swjtx99Author Commented:
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
 
NorieCommented:
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
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
swjtx99Author Commented:
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
 
swjtx99Author Commented:
Hi,

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

Thanks,

swjtx99
0
 
NorieCommented:
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
 
swjtx99Author Commented:
Hi imnorie,

Thanks, Excellent and very fast.

Regards,

swjtx99
0

Featured Post

Industry Leaders: 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!

  • 4
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now