[RESOLVED] Lookup deletion rows problems excel crashing

I have some code below which is crashing.

I need to delete items in sheet 1 not shown in sheet 2 of a lareg spreasheet 35000 plus.

Can someone clean up my code so stops crashing and ist quicker. It seems to work for small number of rows, but not for large number of rows.


There must be something simple wrong. An explannation of the code would be great as well.

VB Code:

Sub SelectedDesigns2()
 
Dim sheetcount As Integer
Dim FileLength As Long
Dim sheetname As String
 
sheetcount = Worksheets.Count
 
If sheetcount < 2 Then
MsgBox ("Muppet! You do not have a selected designs sheet.")
Else
 
'Activate sheet
Worksheets(2).Activate
 
sheetname = ActiveSheet.Name
 
'Activate sheet
Worksheets(1).Activate
 
'Find how many codes there are
FileLength = ActiveSheet.UsedRange.Rows.Count
 
    Range("B:B").Select
    Application.CutCopyMode = False
    Selection.Insert Shift:=xlToRight
    Range("B2").Select
    ActiveCell.FormulaR1C1 = _
    "=IF(ISERROR(VLOOKUP(RC[-1],'" & sheetname & "'!C1:C1,1,FALSE)),""n"",""y"")"
    
    Selection.AutoFill Destination:=Range("B2:B" & FileLength)
End If
 
Range("B:B").Select
Selection.Cells.Copy
Range("b2").PasteSpecial xlPasteValues
 
 
Range("B2").Activate
 
 
 
For i = 2 To FileLength
If ActiveCell.Text = "y" Then
ActiveCell.Offset(1, 0).Activate
Else
ActiveCell.EntireRow.Delete
End If
Next i
 
Range("B:B").Delete
 
 
End Sub

Boris

Boris
For Deletes, you are always better off starting at the bottom of the range and working upwards.
Replace your code

VB Code:

Range("B2").Activate
 
For i = 2 To FileLength
If ActiveCell.Text = "y" Then
ActiveCell.Offset(1, 0).Activate
Else
ActiveCell.EntireRow.Delete
End If
Next i

with

VB Code:

Range("B1").Activate
 
For i = FileLength - 1 To 1 Step -1
    With ActiveCell.Offset(i, 0)
        If .Text = "y" Then
            .EntireRow.Delete
        End If
    End With
Next i

and you should be good to go.

One other thing to note: try to avoid using the .Activate method of a range wherevere possible - it really slows down your code, especially in loops.

Hey kenny,

Its still not working properly. At all really , just run it now for long spreadsheet for 1/2 hour with no sucess. Is some of the other code wrong or badly written, I think it might be do with forumla in cell when trying to delte rows, I am trying to paste values, to avoid this but no luck. Don't think its even pasting values properly. I have hoping a 35,000 spreadsheet would take no more than 5 minutes to finish.

I would apprecaite if you could help debug.

VB Code:

Sub SelectedDesigns2()
 
Dim sheetcount As Integer
Dim FileLength As Long
Dim sheetname As String
 
sheetcount = Worksheets.Count
 
If sheetcount < 2 Then
MsgBox ("Muppet! You do not have a selected designs sheet.")
Else
 
'Activate sheet
Worksheets(2).Activate
 
sheetname = ActiveSheet.Name
 
'Activate sheet
Worksheets(1).Activate
 
'Find how many codes there are
FileLength = ActiveSheet.UsedRange.Rows.Count
 
    Range("B:B").Select
    Application.CutCopyMode = False
    Selection.Insert Shift:=xlToRight
    Range("B2").Select
    ActiveCell.FormulaR1C1 = _
    "=IF(ISERROR(VLOOKUP(RC[-1],'" & sheetname & "'!C1:C1,1,FALSE)),""n"",""y"")"
    
    Selection.AutoFill Destination:=Range("B2:B" & FileLength)
End If
 
Range("B:B").Select
Selection.Cells.Copy
Range("b2").PasteSpecial xlPasteValues
 
 
Range("B2").Activate
 
 
 
For i = 2 To FileLength
If ActiveCell.Text = "y" Then
ActiveCell.Offset(1, 0).Activate
Else
ActiveCell.EntireRow.Delete
End If
Next i
 
Range("B:B").Delete
 
 
End Sub

It looks like you haven't made the changes I suggested.

Also can you upload a sample file?

For some reason, I can't upload .xls files. I tried the code as below- no luck kenny. All I am doing is deleting theitems on sheet 1 that are no on the lookup table sheet 2.

Appreciate Borris.
Sub SelectedDesigns2()

Dim sheetcount As Integer
Dim FileLength As Long
Dim sheetname As String

sheetcount = Worksheets.Count

If sheetcount < 2 Then
MsgBox ("Muppet! You do not have a selected designs sheet.")
Else

'Activate sheet
Worksheets(2).Activate

sheetname = ActiveSheet.Name

'Activate sheet
Worksheets(1).Activate

'Find how many codes there are
FileLength = ActiveSheet.UsedRange.Rows.Count

Range("B:B").Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlToRight
Range("B2").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[-1],'" & sheetname & "'!C1:C1,1,FALSE)),""n"",""y"")"

Selection.AutoFill Destination:=Range("B2:B" & FileLength)
End If

Range("B:B").Select
Selection.Cells.Copy
Range("b:b").PasteSpecial xlPasteValues


Range("B2").Activate



For i = FileLength - 1 To 1 Step -1
With ActiveCell.Offset(i, 0)
If .Text = "y" Then
.EntireRow.Delete
End If
End With
Next i

Range("B:B").Delete


End Sub

Here a winzip file - cheers.

Boris
Based on you test.xls file, I wrote the following code. When I ran it against the test data, it ran in just under 13 minutes.
Per my test, all rows without matches were deleted and none with matches were deleted. (no false Positives or Negatives).

Can you run this version of the code and let me know if it meets your needs.

The main performance boosts in my version of the code are from;

1/ Not using the .Select method
2/ Not using the .Activate method
3/ Not inserting any formulas. (The recalc associated with this was probably your biggest performance hit)
4/ Turning off App level properties that slow performance.

VB Code:

Sub BorisDelete()
 
Dim lRowCount As Long
Dim rngData As Range
Dim rngLookup As Range
Dim oCurrentCalc
Dim lRowNum As Long
Dim vLookupValue As Variant
    
    'This isn't strictly necesary,
    'but I love your Msg!
    If ThisWorkbook.Worksheets.Count < 2 Then
        MsgBox ("Muppet! You do not have a selected designs sheet.")
        Exit Sub
    End If
    
    'Set a reference to the range
    'of know good values
    With Worksheets(2)
        lRowCount = .UsedRange.Rows.Count
    
        'Note: I started at row 1 as there are no headers
        Set rngLookup = .Range(.Cells(1, 1), .Cells(lRowCount, 1))
    End With
    
    'Set a reference to the range
    'of values to test
    With Worksheets(1)
        lRowCount = .UsedRange.Rows.Count
        
        'Note: I started at row 2 to exclude the headers
        Set rngData = .Range(.Cells(2, 1), .Cells(lRowCount, 1))
    End With
    
    'Turn off App level Properties
    'to improve performance
    With Application
        oCurrentCalc = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
    With rngData
        
        'Loop through all rows in reverse
        For lRowNum = .Rows.Count To 1 Step -1
            
            'Get the value from the current row
            vLookupValue = .Cells(lRowNum, 1).Value
            
            'Look for that value in the range of known good values
            'Using the .Find Method of the Range Object
            'Checking for a complete match (xlWhole)
            If rngLookup.Find(What:=vLookupValue, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
                
                'If no match - delete the entire row
                .Rows(lRowNum).EntireRow.Delete Shift:=xlShiftUp
            End If
            
        Next lRowNum
    End With
    
    'Reset App level Properties
    With Application
        .Calculation = oCurrentCalc
        .ScreenUpdating = True
    End With
    
    'Clear Object Variables
    Set rngLookup = Nothing
    Set rngData = Nothing
End Sub

Nice one kenny!Your a true legend.

I doubt very much it can speeded up more, I supsect this is a quick as it gets. Am I right? :thumb: