View Full Version : Speeding up a loop, that does an action when encounters a value
j.smith1981
04-27-2010, 02:02 AM
I have a long section of a macro in Excel 2007.
What it does at the moment is loop down, finds a value like say '#N/A' from a VLOOKUP function.
Removes an entire row if it finds that value, removes the entire row and carries on down until there's no more rows of data to check.
But we are adding almost 3 times as many rows through a products upload of an entire catalogue, here's the code at the moment we have:
Obviously picking the cell to start off from i.e. cells(1,1).select , then does this:
Do
If ActiveCell.Formula = "#N/A" Then
Selection.EntireRow.Delete Shift:=xlUp
Else
ActiveCell.Offset(1, 0).Select
End If
Loop Until IsEmpty(ActiveCell.Offset(0, 1))
Is there anyway of doing this so it saves me allot of time in the macro?
Like select the whole range in a column and then removing them all at once?
I would really appreciate some advice here and as always thanks for any help in advance,
Jeremy.
Bob Phillips
04-27-2010, 02:21 AM
Public Sub ProcessData()
Const TEST_COLUMN As String = "P" '<=== change to suit
Dim LastRow As Long
Dim rng As Range
With ActiveSheet
LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
.Rows(1).Insert
.Cells(1, TEST_COLUMN).Value2 = "temp)"
Set rng = .Cells(1, TEST_COLUMN).Resize(LastRow + 1)
rng.AutoFilter Field:=1, Criteria1:="#N/A"
On Error Resume Next
Set rng = rng.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then rng.EntireRow.Delete
End With
End Sub
j.smith1981
04-30-2010, 02:17 AM
Thanks ever so much for that, I really appreciate it!
Going on another example of this.
I have a form of a CTRL+F function that finds say a cartridge LC02BK in the current cell yea?
Next ones LC1000BK, these are all ink cartridges yea?
They belong to multiple printers right?
This is a working solution I have, just takes for ever to complete, would there be a faster, probably more convenient way of doing this?
Dim fileLoc As String
Dim productcode_fulldescr As String
Dim cat As String
Dim subcat As String
'Opens datasheet for full descr process
fileLoc = ThisWorkbook.Path
Application.Workbooks.Open (fileLoc & "\" & "dataSheet.xls")
Application.Workbooks("dataSheet.xls").Activate
Sheets("Laser Cartridge-Printer Linking").Select
ActiveSheet.UsedRange.Select
Selection.copy
Sheets("Ink Cartridge-Printer Linking").Select
Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious).Select
ActiveCell.Offset(1, -2).Select
ActiveSheet.Paste
Application.Workbooks("UPLOADproducts.xlsm").Activate
Do While IsEmpty(ActiveCell.Offset(0, -1)) = False
productcode_fulldescr = ActiveCell.Formula 'Saves the current cell value as variable
Application.Workbooks("dataSheet.xls").Activate 'Activates data sheet
Sheets("Ink Cartridge-Printer Linking").Select
Cells(2, 3).Select
Dim R As Range, FindAddress As String
'Set the range in which we want to search in
With ActiveSheet.Range("C1:C65536") ' Set to column(s) with product codes going all the way down to the bottom of excel list!
'Search for the first occurrence of the item
Set R = .Find(productcode_fulldescr) 'Finds product code
'If a match is found then
If Not R Is Nothing Then
'Store the address of the cell where the first match is found in a variable
FindAddress = R.Address
Do
R.Select 'Selects found item cell
ActiveCell.Offset(0, -2).Select
cat = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
subcat = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
Application.Workbooks("UPLOADproducts.xlsm").Activate 'Activates last products CSV file
ActiveCell.Offset(0, 3).Select
ActiveCell.Value = ActiveCell.Value & " " & cat & " " & subcat & "<br />"
ActiveCell.Offset(0, -3).Select
Application.Workbooks("dataSheet.xls").Activate
'Search for the next cell with a matching value
Set R = .FindNext(R)
'Search for all the other occurrences of the item i.e.
'Loop as long matches are found, and the address of the cell where a match is found,
'is different from the address of the cell where the first match is found (FindAddress)
Loop While Not R Is Nothing And R.Address <> FindAddress
End If
End With
Application.Workbooks("UPLOADproducts.xlsm").Activate
ActiveCell.Offset(1, 0).Select 'Happens after the current productcode has been found/not found
Loop
Cells(1, 1).Select
'Clear memory
Set R = Nothing
Again much appreciated for any replies,
Jeremy.
Aussiebear
04-30-2010, 02:37 AM
yea as in yes, I presume you mean?
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.