I need to delete all rows containing "$" in Column C on approximately 10000 rows. I've tried this but it takes forever to complete. Someone has a quicker or more efficient way of doing this?
Last = Cells(Rows.Count, "C").End(xlUp).Row
For i = Last To 1 Step -1
If (Cells(i, "C").Value) = "$" Then
Cells(i, "A").EntireRow.Delete
End If
Next i
Try it using .Find()
Dim rng As Range
'Application.ScreenUpdateing = False 'don't enable this until you're sure the
'works correctly
Set rng = Range.Columns("C").Find(what:="$", LookIn:=xlValues)
While Not rng Is Nothing
rng.EntireRow.Delete
Set rng = Range.Columns("C").Find(what:="$", LookIn:=xlValues)
Wend
Set rng = Nothing
Application.ScreenUpdateing = False
You'll probably want to add a couple of extra parameters to the .Find() call to specify exactly what you're looking for - it uses the parameters exactly as they're set in the Find dialog box unless you override them in code, and setting them in code is reflected the next time you open the Find dialog box, so you have to be very careful.
You can deactivate some useless features while you are operating, I added a Timer so that you can compare.
1st option, same action as you delete and no array :
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim TimingT As Long
TimingT = Time
last = Cells(Rows.Count, "C").End(xlUp).Row
For i = last To 1 Step -1
If (Cells(i, "C").Value) = "$" Then
Cells(i, "A").EntireRow.Delete
End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "Total duration of operation : " & Format(Time - TimingT, "hh:mm:ss"), vbInformation, "Procedure finished"
2nd option, with an array :
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim LastR As Long
Dim TimingT As Long
TimingT = Time
Dim ToDel()
LastR = Cells(Rows.Count, "C").End(xlUp).Row
ReDim ToDel(LastR)
For i = 1 To UBound(ToDel)
ToDel(i) = InStr(1, Cells(i, "C"), "$")
Next i
For i = UBound(ToDel) To 1 Step -1
If ToDel(i) <> 0 Then
Rows(i).EntireRow.Delete
End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "Total duration of operation : " & Format(Time - TimingT, "hh:mm:ss"), vbInformation, "Procedure finished"
3rd option, clearcontents and then sort (didn't do it but could be interesting...)
Related
I am running a script to find and delete rows that contain data from after 2018. I am searching through around 650000 rows. Every time I run the script after 5 seconds my cursor becomes the spinning circle and the excel program becomes unresponsive. Here is the code I am using.
Option Explicit
Option Base 1 'row and column index will match array index
Sub removeWrongYear()
Dim i As Long, yearA As Long, rowsCnt As Long
Dim rowsToDelete As Range
Dim vData As Variant
With ActiveSheet
'1st to 635475 row, 20th column
vData = Range(.Cells(1, 20), .Cells(635475, 20))
For i = UBound(vData) To 2 Step -1
If Val(Right(vData(i,1),2)) > 17 Then
Debug.Print Val(Right(vData(i,1),2))
rowsCnt = rowsCnt + 1
If rowsCnt > 1 Then
Set rowsToDelete = Union(rowsToDelete, .Rows(i))
ElseIf rowsCnt = 1 Then
Set rowsToDelete = .Rows(i)
End If
End If
Next i
End With
If rowsCnt > 0 Then
Application.ScreenUpdating = False
rowsToDelete.EntireRow.Delete
Application.ScreenUpdating = True
End If
End Sub
Every time I run the script after 5 seconds my cursor becomes the spinning circle and the excel program becomes unresponsive.
That's normal. VBA is running on the single available UI thread, the same one Excel runs on. While it's busy running your loop, it's not able to respond to other stimuli, and tells you that by putting "(not responding)" in the title bar, until it completes the work and is able to resume doing everything else it needs to do (i.e. listen for mouse & keyboard messages, etc.).
You could add a little DoEvents in the body of that loop to allow Excel to breathe and process pending messages between iterations, but then there's a catch: first, your code will take even longer to complete, and second, if the user is able to select/activate another sheet in the middle of that loop, then this unqualified Range call:
vData = Range(.Cells(1, 20), .Cells(635475, 20))
...will be the source of a run-time error 1004, since you can't do Sheet1.Range(Sheet2.Cells(1,20), Sheet2.Cells(635475,20)) and expect Excel to know what to do with that (assuming Sheet2 was active when the loop started, and the user activated Sheet1 in the middle of it).
This answer provides what appears to be the most efficient approach to conditionally deleting lines when a lot of rows are involved. If you can, add a helper column to calculate your criteria (e.g. make it return TRUE for rows to keep and FALSE for rows to delete), then use Worksheet.Replace and Worksheet.SpecialCells to perform the filtering and deletion:
.Columns("Z:Z").Replace What:=False, _
Replacement:="", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
.Columns("Z:Z").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Then you don't need a loop, and it might actually complete before you get to count to 5 seconds.
Other than that, long-running operations are just that: long-running operations. Own it:
Application.StatusBar = "Please wait..."
Application.Cursor = xlWait
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'..code..
Application.Cursor = xlDefault
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.StatusBar = False
This seems pretty quick. It puts results in U1 and down so you'd probably want to amend that. This extracts the values you want into a second array.
Sub removeWrongYear()
Dim i As Long, vData As Variant, v2(), j As Long
vData = Range(Cells(1, 20), Cells(635475, 20))
ReDim v2(1 To UBound(vData, 1), 1 To 1)
For i = UBound(vData) To 2 Step -1
If Val(Right(vData(i, 1), 2)) <= 17 Then
j = j + 1
v2(j, 1) = vData(i, 1)
End If
Next i
Range("U1").Resize(j, 1) = v2
End Sub
This uses an AutoFilter - the more rows to delete, the faster it gets
Rows: 1,048,575 (Deleted: 524,286), Cols: 21 (70 Mb xlsb file)
Time: 6.90 sec, 7.49 sec, 7.21 sec (3 tests)
Test data shown in images bellow
How it works
It generates a temporary helper column with formula "=RIGHT(T1, 2)" (first empty column)
Applies a filter for the years to keep ("<18") in the temp column
Copies all visible rows to a new sheet (not including the temp column)
Removes the initial sheet
Renames the new sheet to the initial sheet name
Option Explicit
Public Sub RemoveYearsAfter18()
Dim ws As Worksheet, wsName As String, lr As Long, lc As Long
Dim ur As Range, filterCol As Range, newWs As Worksheet
Set ws = Sheet1 'Or: Set ws = ThisWorkbook.Worksheets("Sheet1")
wsName = ws.Name
lr = ws.Cells(ws.Rows.Count, "T").End(xlUp).Row 'Last Row in col T (or 635475)
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column 'Last Col in row 1
Set ur = ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc))
Set filterCol = ws.Range(ws.Cells(1, lc + 1), ws.Cells(lr, lc + 1)) 'Exclude Headers
OptimizeApp True
Set newWs = ThisWorkbook.Worksheets.Add(After:=ws) 'Add new sheet
With filterCol
.Formula = "=RIGHT(T1, 2)"
.Cells(1) = "FilterCol" 'Column header
.Value2 = .Value2 'Convert formulas to values for filter
End With
filterCol.AutoFilter Field:=1, Criteria1:="<18" 'Reverse filter
ur.Copy 'Copy visible data
With newWs.Cells
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteAll 'Paste data on new sheet
.Cells(1).Select
End With
ws.Delete 'Delete old sheet
newWs.Name = wsName
OptimizeApp False
End Sub
Private Sub OptimizeApp(ByVal speedUp As Boolean)
Application.Calculation = IIf(speedUp, xlCalculationManual, xlCalculationAutomatic)
Application.ScreenUpdating = Not speedUp
Application.DisplayAlerts = Not speedUp
Application.EnableEvents = Not speedUp
End Sub
Before
After
This code process 635475 Rows x 20 Columns in 12.48 seconds on my fast computer and 33.32 seconds on my old computer (0.84 and 2.06 seconds for 38k x 20).
Option Explicit
Sub removeWrongYear2()
Const DATE_COLUMN = 20
Dim StartTime As Double: StartTime = Timer
Dim data() As Variant, results() As Variant
Dim c As Long, r As Long, r2 As Long
With ActiveSheet
data = .UsedRange.Value
ReDim results(1 To UBound(data), 1 To UBound(data, 2))
For r = 2 To UBound(data)
If Val(Right(data(r, DATE_COLUMN), 2)) <= 17 Then
r2 = r2 + 1
For c = 1 To UBound(data, 2)
results(r2, c) = data(r, c)
Next
End If
Next
If r2 > 0 Then
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
.UsedRange.Offset(1).Value = results
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End If
End With
Debug.Print Round(Timer - StartTime, 2)
End Sub
Sub Setup()
Dim data, r, c As Long
Const LASTROW = 635475
Cells.Clear
data = Range(Cells(1, 1), Cells(LASTROW, 20)).Value
For r = 1 To UBound(data)
For c = 1 To 19
data(r, c) = Int((LASTROW * Rnd) + 100)
Next
data(r, 20) = Int((10 * Rnd) + 10)
Next
Application.ScreenUpdating = False
Range(Cells(1, 1), Cells(LASTROW, 20)).Value = data
Application.ScreenUpdating = True
End Sub
Sort() & AutoFilter() are always a good pair:
Sub nn()
Dim sortRng As Range
With ActiveSheet.UsedRange ' reference all data in active sheet
With .Offset(, .Columns.Count).Resize(, 1) ' get a helper column right outside data
.Formula = "=ROW()" ' fill it with sequential numbers from top to down
.Value = .Value ' get rid of formulas
Set sortRng = .Cells ' store the helper range
End With
With .Resize(, .Columns.Count + 1) ' consider data and the helper range
.Sort key1:=.Cells(1, 20), order1:=xlAscending, Header:=xlNo ' sort it by data in column 20
.AutoFilter Field:=20, Criteria1:=">=01/01/2018" ' filter it for data greater than 2017
.Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete ' delete filtered data
.Parent.AutoFilterMode = False ' remove filter
.Sort key1:=sortRng(1, 1), order1:=xlAscending, Header:=xlNo ' sort things back by means of helper column
.Columns(.Columns.Count).ClearContents ' clear helper column
End With
End With
End Sub
in my test a 768k row by 21 columns data took 11 seconds
Is there a way to speed this code up? I need it to remove and write the same content to the cell to force other VBA code to run that's on another column. Which is what it does, just super damn slow. And there is sometimes 2000 entries/rows on this sheet. Its about 3 seconds per cell, and it almost maxes my CPU out lol. (i7 6850k # 4.4ghz).
Reason for it, is sometimes the data is copied from an old version of the spreadsheet to a new version, and the VBA updated columns wont update, unless I physically change the cell its checking.
Sub ForceUpdate()
On Error GoTo Cleanup
Application.ScreenUpdating = False ' etc..
ThisWorkbook.Sheets("Sales Entry").Unprotect "password!"
Dim cell As Range, r As Long
r = 2
For Each cell In ThisWorkbook.Sheets("Sales Entry").Range("E2:E10")
If Len(cell) > 0 Then
Dim old As String
old = cell.Value
ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = ""
ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = old
r = r + 1
End If
Next cell
Cleanup:
Application.ScreenUpdating = True ' etc..
ThisWorkbook.Sheets("Sales Entry").Protect "password!", _
AllowSorting:=True, AllowFiltering:=True
End Sub
The code in the other VBA section is
If StrComp("pp voice", Target.Value, vbTextCompare) = 0 Then
Target.Value = "PP Voice"
Target.Offset(0, 8).Value = "N\A"
Target.Offset(0, 8).Locked = True
Target.Offset(0, 10).Value = "N\A"
Target.Offset(0, 10).Locked = True
End If
Target.Value is referring to the E column in the first piece of code. At the moment I have the first piece attached to a button, but it's way to slow. And the target machines are no where near as powerful as mine.
Use application.enableevents = false and application.calculation = xlcalculationmanual. Turn them back on before exiting. You must be either triggering an large event or complex calculation cycle if it it taking 3 seconds per cell.
Change,
Dim cell As Range, r As Long
r = 2
For Each cell In ThisWorkbook.Sheets("Sales Entry").Range("E2:E10")
If Len(cell) > 0 Then
Dim old As String
old = cell.Value
ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = ""
ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = old
r = r + 1
End If
Next cell
... to,
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim cell As Range
With ThisWorkbook.Sheets("Sales Entry")
For Each cell In .Range("E2:E10")
If CBool(Len(cell.Value2)) Then
cell = cell.Value2
End If
Next cell
End With
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Try this
Option Explicit
Sub ForceUpdate()
On Error GoTo Cleanup
Dim SalesEntrySheet As Worksheet
Set SalesEntrySheet = ThisWorkbook.Sheets("Sales Entry")
Application.ScreenUpdating = False ' etc..
SalesEntrySheet.Unprotect "password!"
Dim cell As Range, r As Long
Dim ArrayPos As Long
Dim SalesEntrySheetArray As Variant
With SalesEntrySheet
'Starting with row one into the array to ease up the referencing _
so Array entry 2 will be for row 2
SalesEntrySheetArray = .Range("E1:E" & .Cells(.Rows.Count, "E").End(xlUp).Row)
'Clearing the used range in Col E
'If you are using a WorkSheet_Change for the second part of your code then you should rather make this a loop
.Range("E1:E" & .Cells(.Rows.Count, "E").End(xlUp).Row).Value = ""
'Putting the values back into the sheet
For ArrayPos = 2 To UBound(SalesEntrySheetArray, 1)
.Cells(ArrayPos, "E").Value = SalesEntrySheetArray(ArrayPos, 1)
Next ArrayPos
End With
Cleanup:
Application.ScreenUpdating = True ' etc..
ThisWorkbook.Sheets("Sales Entry").Protect "password!", AllowSorting:=True, _
AllowFiltering:=True
End Sub
Try to use with statement.
and take a look at Optimizing VBA macro
Sub ForceUpdate()
On Error GoTo Cleanup
Application.ScreenUpdating = False ' etc..
ThisWorkbook.Sheets("Sales Entry").Unprotect "password!"
Dim cell As Range, r As Long
r = 2
With ThisWorkbook.Sheets("Sales Entry")
For Each cell In .Range("E2:E10")
If Len(cell) > 0 Then
Dim old As String
old = cell.Value
.Cells(4, r) = ""
.Cells(4, r) = old
r = r + 1
End If
Next cell
End With
Cleanup:
Application.ScreenUpdating = True ' etc..
ThisWorkbook.Sheets("Sales Entry").Protect "password!", AllowSorting:=True, AllowFiltering:=True
End Sub
I'm trying to create an advanced filter for the below table but the code below is just hiding the cells. It's working but my problem with it is if i filter something and then I drag to fill status or any other cells it will override the cells in between for example in filter mode I have 2 rows one is 1st row and the other one is at row 20 if I drag to fill status it will replace the status of all cells in between 1 and 20 and don't know how to work it out, i know this happens because I'm hiding the cells and not actually filtering them.
Any help will be much appreciated.
[Data Table][1]
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
r1 = Target.Row
c1 = Target.Column
If r1 <> 3 Then GoTo ending:
If ActiveSheet.Cells(1, c1) = "" Then GoTo ending:
Dim LC As Long
With ActiveSheet
LC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
End With
ActiveSheet.Range("4:10000").Select
Selection.EntireRow.Hidden = False
LR = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For r = 5 To LR
For c = 1 To LC
If ActiveSheet.Cells(2, c) = "" Or ActiveSheet.Cells(3, c) = "" Then GoTo nextc:
If ActiveSheet.Cells(2, c) = "exact" And UCase(ActiveSheet.Cells(r, c)) <> UCase(ActiveSheet.Cells(3, c)) Then ActiveSheet.Rows(r).EntireRow.Hidden = True: GoTo nextr:
If Cells(2, c) = "exact" Then GoTo nextc:
j = InStr(1, UCase(ActiveSheet.Cells(r, c)), UCase(ActiveSheet.Cells(3, c)))
If ActiveSheet.Cells(2, c) = "partial" And j = 0 Then ActiveSheet.Rows(r).EntireRow.Hidden = True: GoTo nextr:
nextc:
Next c
nextr:
Next r
ending:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
The below code will be the answer to the question on how to create an advanced search based on multiple criteria on what the user selects in the table.
I will need a little bit of help with how to check if the user selected by mistake an empty cell I will need to make excel ignore filtering the blank cell. Also, I will need to make excel first to check if the yellow cells A3 to T3 has data in and if it has and i press the filter button will filter by the range A3:T3 and ignore the current user selection if there is no data in range A3:T3 will filter by the user selection and in the range A3:T3, if it has data will only filter by data cell that has data in them and ignore empty ones.
Sub advancedMultipleCriteriaFilter()
Dim cellRng As Range, tableObject As Range, subSelection As Range
Dim filterCriteria() As String, filterFields() As Integer
Dim i As Integer
If Selection.Rows.Count > 1 Then
MsgBox "Cannot apply filters to multiple rows within the same column. Please make another selection and try again.", vbInformation, "Selection Error!"
Exit Sub
End If
Application.ScreenUpdating = False
i = 1
ReDim filterCriteria(1 To Selection.Cells.Count) As String
ReDim filterFields(1 To Selection.Cells.Count) As Integer
Set tableObject = Selection.CurrentRegion
For Each subSelection In Selection.Areas
For Each cellRng In subSelection
filterCriteria(i) = cellRng.Text
filterFields(i) = cellRng.Column - tableObject.Cells(1, 1).Column + 1
i = i + 1
Next cellRng
Next subSelection
With tableObject
For i = 1 To UBound(filterCriteria)
.AutoFilter field:=filterFields(i), Criteria1:=filterCriteria(i)
Next i
End With
Set tableObject = Nothing
Application.ScreenUpdating = True
End Sub
Sub resetFilters()
Dim sht As Worksheet
Dim LastRow As Range
Application.ScreenUpdating = False
On Error Resume Next
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
Range("A3:T3").ClearContents
Application.ScreenUpdating = True
Call GetLastRow
End Sub
Private Sub GetLastRow()
'Step 1: Declare Your Variables.
Dim LastRow As Long
'Step 2: Capture the last used row number.
LastRow = Cells(Rows.Count, 8).End(xlUp).Row
'Step 3: Select the next row down
Cells(LastRow, 8).Offset(1, 0).Select
End Sub
Currently I have 10Kx15 Rows worth of raw data imported in an excel spreadsheet.
I have a number of fields that are cleansed but the one of interest is a field called "Hazard". For every instance of Hazard encountered, we need to strip this out.
This is the code I use to cleanse (partially) my data set:
Sub dataCleanse()
Dim Last
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Last = Cells(Rows.Count, "F").End(xlUp).Row
For i = Last To 1 Step -1
If (Cells(i, "F").Value) = "Hazard" Then
Cells(i, "A").EntireRow.Delete
End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
To process 10,000 records or so it takes 10-15 seconds. I have experimented with using auto-filter, but when I use .EntireRow.Delete it strips out the rows underneath the filtered criteria.
i.e. If we have rows 1 and 3 with 'Hazard' and use auto-filter, it will also delete row2 which does not have 'Hazard'.
I have also set the calculation to Manual first and then Automatic so it doesn't refresh each time.
Are there any suggestions that could be offered to increase the speed of my macro?
Thank you!
you could go with the following Autofilter approach
Option Explicit
Sub dataCleanse()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
With ActiveSheet
' insert "dummy" header cell for Autofilter to work
.Range("F1").Insert
.Range("F1").value = "header"
With .Range("F1", .Cells(.Rows.Count, "F").End(xlUp))
.AutoFilter Field:=1, Criteria1:="Hazard"
With .Offset(1).Resize(.Rows.Count - 1)
If Application.WorksheetFunction.Subtotal(103, .Columns(1)) > 1 Then .SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
.AutoFilter
End With
.Range("F1").Delete 'remove "dummy" header cell
End With
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
processing 10,000 records of 250 columns each in much less then a second
I am not sure if this will be faster, but my suggestion is to select column F, find an instance of "Hazard", delete that row, and repeat the process until "Hazard" is not found in column F.
Dim iRow As Integer
Application.ScreenUpdating = False
Columns("F:F").Select
Set RangeObj = Selection.Find(What:="Hazard", LookIn:=xlValues, MatchCase:=True)
Do Until (RangeObj Is Nothing)
iRow = RangeObj.Row
Rows(iRow & ":" & iRow).Delete
Columns("F:F").Select
Set RangeObj = Selection.Find(What:="Hazard", LookIn:=xlValues, MatchCase:=True)
Loop
Application.ScreenUpdating = True
Please give it a try.
This solution is not faster for small datasets, but it will be for very large datasets. The code looks longer, but handling the arrays is much faster than manipulating the workbook. (I am sure there are more efficient ways to shorten the array). BTW - your code worked for me on the example dataset I put together. If this doesn't work on your data, please post a small example of your input and what the result should look like.
Example input:
Output from macro:
Macro code using arrays:
Option Explicit
Sub dataCleanse2()
Dim nRows As Long, nCols As Long
Dim i As Long, j As Long, k As Long
Dim myRng As Range
Dim myArr() As Variant, myTmpArr() As Variant
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set myRng = Sheets("Sheet1").UsedRange
myArr = myRng.Value2
nRows = UBound(myArr, 1)
nCols = UBound(myArr, 2)
For i = nRows To 1 Step -1
If CStr(myArr(i, 6)) = "Hazard" Then
ReDim Preserve myTmpArr(1 To nRows - 1, 1 To nCols)
For j = 1 To i - 1
For k = 1 To nCols
myTmpArr(j, k) = myArr(j, k)
Next k
Next j
For j = i To nRows - 1
For k = 1 To nCols
myTmpArr(j, k) = myArr(j + 1, k)
Next k
Next j
nRows = UBound(myTmpArr, 1)
Erase myArr
myArr = myTmpArr
Erase myTmpArr
End If
Next i
myRng.Clear
Set myRng = Sheets("Sheet1").Range(Cells(1, 1), Cells(nRows, nCols))
myRng.Value2 = myArr
Set myRng = Nothing
Erase myArr
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Thanks for the help everyone! I went for an alternative approach (apart from the one user has posted), that made use of an array. I'm still familiarizing myself with arrays (newish to VBA / programming in general), but found that when I loaded the values in an array there was an improvement by around 50% in speed! I don't know the exact reason why loading into an array is that much faster, but I'm assuming it is to do with the fact that it processes the array as an aggregate rather than individual cell values.
Sub CleanseAction()
Dim Last
Dim prevCalcMode As Variant
Application.ScreenUpdating = False
prevCalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
Last = Cells(Rows.Count, "H").End(xlUp).Row
For i = Last To 1 Step -1
If (Cells(i, "H").Value) = "Hazard" Then
Cells(i, "A").EntireRow.Delete
End If
Next i
Application.Calculation = prevCalcMode
Application.ScreenUpdating = True
This question already has answers here:
Delete Row based on Search Key VBA
(3 answers)
Closed 8 years ago.
I'm creating a fast sub to do a validity check for emails. I want to delete entire rows of contact data that do not contain a '#' in the 'E' Column. I used the below macro, but it operates too slowly because Excel moves all the rows after deleting.
I've tried another technique like this: set rng = union(rng,c.EntireRow), and afterwards deleting the entire range, but I couldn't prevent error messages.
I've also experimented with just adding each row to a selection, and after everything was selected (as in ctrl+select), subsequently deleting it, but I could not find the appropriate syntax for that.
Any ideas?
Sub Deleteit()
Application.ScreenUpdating = False
Dim pos As Integer
Dim c As Range
For Each c In Range("E:E")
pos = InStr(c.Value, "#")
If pos = 0 Then
c.EntireRow.Delete
End If
Next
Application.ScreenUpdating = True
End Sub
You don't need a loop to do this. An autofilter is much more efficient. (similar to cursor vs. where clause in SQL)
Autofilter all rows that don't contain "#" and then delete them like this:
Sub KeepOnlyAtSymbolRows()
Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long
Set ws = ActiveWorkbook.Sheets("Sheet1")
lastRow = ws.Range("E" & ws.Rows.Count).End(xlUp).Row
Set rng = ws.Range("E1:E" & lastRow)
' filter and delete all but header row
With rng
.AutoFilter Field:=1, Criteria1:="<>*#*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
' turn off the filters
ws.AutoFilterMode = False
End Sub
NOTES:
.Offset(1,0) prevents us from deleting the title row
.SpecialCells(xlCellTypeVisible) specifies the rows that remain after the autofilter has been applied
.EntireRow.Delete deletes all visible rows except for the title row
Step through the code and you can see what each line does. Use F8 in the VBA Editor.
Have you tried a simple auto filter using "#" as the criteria then use
specialcells(xlcelltypevisible).entirerow.delete
note: there are asterisks before and after the # but I don't know how to stop them being parsed out!
Using an example provided by user shahkalpesh, I created the following macro successfully. I'm still curious to learn other techniques (like the one referenced by Fnostro in which you clear content, sort, and then delete). I'm new to VBA so any examples would be very helpful.
Sub Delete_It()
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With ActiveSheet
.Select
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
.DisplayPageBreaks = False
'Firstrow = .UsedRange.Cells(1).Row
Firstrow = 2
Lastrow = .Cells(.Rows.Count, "E").End(xlUp).Row
For Lrow = Lastrow To Firstrow Step -1
With .Cells(Lrow, "E")
If Not IsError(.Value) Then
If InStr(.Value, "#") = 0 Then .EntireRow.Delete
End If
End With
Next Lrow
End With
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub
When you are working with many rows and many conditions, you better off using this method of row deletion
Option Explicit
Sub DeleteEmptyRows()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim i&, lr&, rowsToDelete$, lookFor$
'*!!!* set the condition for row deletion
lookFor = "#"
Set ws = ThisWorkbook.Sheets("Sheet1")
lr = ws.Range("E" & Rows.Count).End(xlUp).Row
ReDim arr(0)
For i = 1 To lr
If StrComp(CStr(ws.Range("E" & i).Text), lookFor, vbTextCompare) = 0 then
' nothing
Else
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr) - 1) = i
End If
Next i
If UBound(arr) > 0 Then
ReDim Preserve arr(UBound(arr) - 1)
For i = LBound(arr) To UBound(arr)
rowsToDelete = rowsToDelete & arr(i) & ":" & arr(i) & ","
Next i
ws.Range(Left(rowsToDelete, Len(rowsToDelete) - 1)).Delete Shift:=xlUp
Else
Application.ScreenUpdating = True
MsgBox "No more rows contain: " & lookFor & "or" & lookFor2 & ", therefore exiting"
Exit Sub
End If
If Not Application.ScreenUpdating Then Application.ScreenUpdating = True
Set ws = Nothing
End Sub
Instead of looping and referencing each cell 1 by 1, grab everything and put it into a variant array; Then loop the variant array.
Starter:
Sub Sample()
' Look in Column D, starting at row 2
DeleteRowsWithValue "#", 4, 2
End Sub
The Real worker:
Sub DeleteRowsWithValue(Value As String, Column As Long, StartingRow As Long, Optional Sheet)
Dim i As Long, LastRow As Long
Dim vData() As Variant
Dim DeleteAddress As String
' Sheet is a Variant, so we test if it was passed or not.
If IsMissing(Sheet) Then Set Sheet = ActiveSheet
' Get the last row
LastRow = Sheet.Cells(Sheet.Rows.Count, Column).End(xlUp).Row
' Make sure that there is work to be done
If LastRow < StartingRow Then Exit Sub
' The Key to speeding up the function is only reading the cells once
' and dumping the values to a variant array, vData
vData = Sheet.Cells(StartingRow, Column) _
.Resize(LastRow - StartingRow + 1, 1).Value
' vData will look like vData(1 to nRows, 1 to 1)
For i = LBound(vData) To UBound(vData)
' Find the value inside of the cell
If InStr(vData(i, 1), Value) > 0 Then
' Adding the StartingRow so that everything lines up properly
DeleteAddress = DeleteAddress & ",A" & (StartingRow + i - 1)
End If
Next
If DeleteAddress <> vbNullString Then
' remove the first ","
DeleteAddress = Mid(DeleteAddress, 2)
' Delete all the Rows
Sheet.Range(DeleteAddress).EntireRow.Delete
End If
End Sub