[RESOLVED] Lookup deletion rows problems excel crashing

[gphillips]

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.

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

[DKenny]

Boris
For Deletes, you are always better off starting at the bottom of the range and working upwards.
Replace your codeRange("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
withRange("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.

[gphillips]

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.


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

[DKenny]

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

Also can you upload a sample file?

[gphillips]

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

[gphillips]

Here a winzip file - cheers.

[DKenny]

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.
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

[gphillips]

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: