In the code attached (two macros) if I call "SortBy Ecode" from within "EcodeKeep" the code never ends. (or at least doesn't end within 5 min when I force Quit excel).
However, If I run "SortByEcode" seperately before running "EcodeKeep" they each run in under 2 seconds.
There are a little over 19K rows of data in the spreadsheet. Also, this is my first attempt at working with arrays in VBA.
What am I doing wrong?
Sub EcodeKeep()
Dim i As Long
Dim LastRow As Long
Call SortByEcode 'Calling this sort macro here causes this code to run forever.
Dim wks As Worksheet
Set wks = rawData5 'Work in sheet("RawEquipHistory")
LastRow = wks.Range("A" & Rows.Count).End(xlUp).Row
StartTime = Timer
Dim Ecode_arr() As Variant
ReDim Ecode_arr(LastRow)
Dim Results_arr() As String
ReDim Results_arr(LastRow)
For i = 0 To LastRow - 1 'Read data into Ecode_arr(i)
Ecode_arr(i) = wks.Range("A" & i + 1)
Next i
wks.Range("AM1") = "ECODE KEEP" 'Add the header to "S1"
For i = 0 To LastRow - 1
If Ecode_arr(i + 1) <> Ecode_arr(i) Then
Results_arr(i) = True
Else
Results_arr(i) = False
End If
wks.Range("AM" & i + 2) = Results_arr(i)
Next i
End Sub
Sub SortByEcode()
' SORT sheet by E-Code (Column A)
Dim LastRow As Long
LastRow = ThisWorkbook.Sheets("RawEquipHistory").Range("A" & Rows.Count).End(xlUp).Row
With ThisWorkbook.Sheets("RawEquipHistory").Sort ' SORT sheet by E-Code(a)
.SortFields.Clear
.SortFields.Add Key:=Range("A1:A" & LastRow), Order:=xlAscending
.SetRange Range("A1:AZ" & LastRow)
.Header = xlYes
.Apply
End With
End Sub
Your loop isn't infinite, only inefficient.
Unless you've disabled automatic calculations, application/worksheet events, and screen updating, then every time a cell is written to, Excel tries to keep up with the changes, and eventually fails to do so, goes "(not responding)", and at that point there's not much left to do but wait it out... and it can take a while.
You can work on the symptoms and disable automatic calculations, application/worksheet events, and screen updating - your code will run to completion, faster.
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False
Of course you would then reset these to their original values after the loops are completed, and you want to be careful to also reset them if anything goes wrong in the procedure, i.e. whenever you toggle those, you want an error-handling subroutine.
Or you can work on the root cause, and tweak the approach slightly, by reducing the worksheet operations to a bare minimum: one single read, one single write. ...and then whether automatic calculations are enabled, whether Excel fires worksheet events and repaints the screen every time you write to a cell will make no difference at all.
The secret sauce, is variant arrays. You had the right idea here:
Dim Ecode_arr() As Variant
ReDim Ecode_arr(LastRow)
Dim Results_arr() As String
ReDim Results_arr(LastRow)
But then reading the values one by one takes a toll:
For i = 0 To LastRow - 1 'Read data into Ecode_arr(i)
Ecode_arr(i) = wks.Range("A" & i + 1)
Next i
Don't bother sizing the arrays, keep them as plain old Variant wrappers - with Application.Transpose, you can get a one-dimensional Variant array from your one-column source range:
Dim ecodes As Variant
ecodes = Application.Transpose(wks.Range("A1:A" & LastRow).Value)
Now you can iterate this array to populate your output array - but don't write to the worksheet just yet: writing the values one by one to the worksheet is eliminating the need for a result/output array in the first place!
Note that because we are assigning a Boolean value with True in one branch and False in the other branch of a conditional, we can simplify the assignment by assigning directly to the Boolean expression of the conditional:
ReDim results(LBound(ecodes), UBound(ecodes))
Dim i As Long
For i = LBound(results) To UBound(results) - 1
results(i) = ecodes(i + 1) <> ecodes(i)
Next
And now that the results array is populated, we can dump it onto the worksheet, all at once - and since this is the only worksheet write we're doing, it doesn't matter that Excel wants to recalculate, raise events, and repaint: we're done!
wks.Range("AM2:AM" & i + 1).Value = results
Note: none of this is tested code, an off-by-one error might have slipped in as I adjusted the offsets (arrays received from Range.Value will always be 1-based). But you get the idea :)
Related
I have a worksheet with ~4,000 rows and 300 columns.
For my report, I have to remove a bunch columns and only keep about 50 of them, based on the header (in row 1).
I have the following code (obviously only listing 4 of the 50 columns) but this takes about 40 minutes to run. Is there a way to increase the performance of this?
Sub delete_columns()
Mylist = Array("ID","Status","First_Name","Last_Name")
LC = Cells(1, Columns.Count).End(xlToLeft).Column
For mycol = LC To 1 Step -1
x = ""
On Error Resume Next
x = WorksheetFunction.Match(Cells(1, mycol), Mylist, 0)
If Not IsNumeric(x) Then Columns(mycol).EntireColumn.Delete
Next mycol
End sub
Collect the columns you want to delete in a variable ColumnsToDelete first and delete all of them at once after the loop. Advantage of that is you have only one delete action (each action takes time) so this is less time consuming. Also you don't need to deactivate screen updating or calculation with this because this is already optimized to run only one update/calculation.
Option Explicit
Public Sub delete_columns()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") ' adjust your sheet name here!
Dim ColumnNames As Variant
ColumnNames = Array("ID", "Status", "First_Name", "Last_Name")
Dim LastColumn As Long
LastColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Dim ColumnsToDelete As Range
Dim iCol As Long
For iCol = 1 To LastColumn ' no need for backwards looping if we delete after loop.
Dim MatchedAt As Double
MatchedAt = 0
On Error Resume Next ' deactivate error reporting
MatchedAt = WorksheetFunction.Match(ws.Cells(1, iCol), ColumnNames, 0)
On Error Goto 0 'NEVER forget to re-activate error reporting!
If MatchedAt > 0 Then
If ColumnsToDelete Is Nothing Then ' add first found column
Set ColumnsToDelete = ws.Columns(iCol).EntireColumn
Else ' add all other found columns with union
Set ColumnsToDelete = Union(ColumnsToDelete, ws.Columns(iCol).EntireColumn)
End If
End If
Next mycol
' if columns were found delete them otherwise report
If Not ColumnsToDelete Is Nothing Then
ColumnsToDelete.Delete
Else
MsgBox "Nothing found to delete."
End If
End Sub
The first step would be to preface your Subroutine with
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
and end it with
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
This will mean that Excel doesn't try to recalculate the sheet every time you delete a column, it does it in one fell swoop at the end.
Unfortunately, we are working with Columns here, not Rows — otherwise, I'd suggest using a Filter to drop the Loop. Match can sometimes be a bit slow, so you may want to consider swapping the Array for a Dictionary, or having a Fuction to quickly loop through the Array and search for the value.
Not strictly a speed thing, but using Application.Match instead of WorksheetFunction.Match allows you to streamline your code inside the loop slightly:
If IsError(Application.Match(Cells(1, mycol).Value, Mylist, 0)) Then Columns(mycol).Delete
Keep only columns occurring in titles array
"For my report, I have to remove a bunch columns and only keep about 50 of them, based on the header (in row 1)."
The slightly shortened code in OP only lists 4 of the 50 headers in array MyList ; thus following MCV E rules
In the following example code I demonstrate a way to approve performance, explained in several steps;
in my tests it performed in 0.09 seconds over 3.000 rows (against nearly the same time of 0.10 seconds for #PEH 's methodically fine approach
, but which imho should be changed to If MatchedAt = 0 Then instead of > 0 to include the listed columns, not to delete them!)
[1] Don't focus on deletion (~250 columns), but get an array of column numbers to be maintained (~4..50 columns); see details at help function getNeededColNums()
showing an undocumented use of Application.Match()
[2] Hide the found columns to preserve them from eventual deletion
[3] Delete all columns left visible in one go using the SpecialCells method
[4] Redisplay the hidden columns left untouched
A main reason for the mentioned poor performance in the original post (OP) is that repeated deletion of columns shifts the entire worksheet up to 250 times (i.e. ~75% of titled columns).
A further note to the original post: always use Option Explicit to force variable declarations and fully qualify all range references,
e.g. like x = Application.Match(Sheet1.Cells(1, mycol), myList, 0).
Sub ExampleCall()
Dim t#: t = Timer
'[1]Get array of column numbers to be maintained
Dim ws As Worksheet: Set ws = Sheet1 ' << reference wanted sheet e.g. by Code(Name)
Dim cols: cols = getNeededColNums(ws) '1-based 1-dim array
Debug.Print Join(cols, ",")
'[2]Hide found columns to preserve them from eventual deletion
Dim i As Long
For i = 1 To UBound(cols)
ws.Columns(cols(i)).Hidden = True
Next
'[3]Delete columns left visible
Application.DisplayAlerts = False
ws.Range("A1", ws.Cells(1, LastCol(ws))).SpecialCells(xlCellTypeVisible).EntireColumn.Delete
Application.DisplayAlerts = True
'[4]Redisplay untouched hidden columns
ws.Range("A1", ws.Cells(1, UBound(cols))).EntireColumn.Hidden = False
Debug.Print "**" & Format(Timer - t, "0.00 secs") ' 0.09 seconds!
End Sub
'Help function getNeededColNums()
Note that Application.Match() doesn't compare only a single argument against a complete list of column titles, but is capable to pass even an array as first argument:
Application.Match(titles, allTitles, 0)
Assuming existing titles, this results in a 1-based array with the same dimension boundaries as the first argument and which returns the found column numbers. So you get valid list without need of further checks (IsNumeric or Not IsError in the late-bound Application form) or even error handling in the WorksheetFunction.
Function getNeededColNums(ws As Worksheet)
'Note: returns 1-based 1-dim array (assuming existant titles)
Dim titles As Variant
titles = Array("ID", "Status", "First_Name", "Last_Name")
'get all existing titles
Dim allTitles As Variant
allTitles = ws.Range("1:1").Resize(1, LastCol(ws)).Value2
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'get column numbers to be maintained
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
getNeededColNums = Application.Match(titles, allTitles, 0)
End Function
Help function LastCol()
Function LastCol(ws As Worksheet, Optional rowNum As Long = 1) As Long
'Purp.: return the last column number of a title row in a given worksheet
LastCol = ws.Cells(rowNum, ws.Columns.Count).End(xlToLeft).Column
End Function
I am facing a minor issue, basically I have successfully done the macro process for one string. But I am unable to process the same vba macro for keeping multiple strings and delete the unwanted data present in the CSV file.
Currently the below code only keeps the rows with string Event Magnitude: and deletes the rest.
However I want to add multiple strings like Event Duration:,
Trigger Date:, Trigger Time: in the same macro and I am unsure how to do it.
IF I can add multiple strings this macro will check for all 4 strings and keep that data and delete the rest of the data.
Sub DeleteNotMIS()
Dim r As Long, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For r = lr To 2 Step -1
If InStr(Cells(r, 1), "Event Magnitude: ") = 0 Then Rows(r).Delete
Next r
End Sub
You need to define a list of keywords to keep KeywordsToKeep = Array("Event Magnitude: ", "Trigger Date:") and then check in another loop each keyword
Option Explicit
Public Sub DeleteNotMIS()
Dim LastRow As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim KeywordsToKeep() As Variant
KeywordsToKeep = Array("Event Magnitude: ", "Trigger Date:") 'Add other keywords here
Dim iRow As Long, eKey As Variant, FoundKey As Boolean
For iRow = LastRow To 2 Step -1
FoundKey = False 'initialize
For Each eKey In KeywordsToKeep
If InStr(Cells(iRow, 1), eKey) <> 0 Then
FoundKey = True
Exit For 'we don't need to check further keys if we already found one.
End If
Next eKey
If Not FoundKey Then Rows(iRow).Delete
Next iRow
End Sub
If each keyword can occur only once in the CSV file …
this approach is slow, because it has to check every row (row by row). A faster approach then would be to use the Range.Find method to find each keyword directly and extract/copy it to a new sheet.
I need some help with a particular macro I am working on.
The macro processes columns of data that have been imported from a pdf file. The import process produces multiple sheets of consistent data, all variables stay in the same columns across multiple sheets. This macro needs to read the three columns of numbers, subtract all cells in two columns one from another, place solved value in an empty column at the end of each row. Then repeat with another combination of two columns. After that, it needs to compare the solved values against a margin value, and generate a new sheet that pulls the whole row of data that the failed margin value is in to a new sheet at the front of the workbook.
This is what I have so far.
I can preform the function on one sheet so far, but don't know how to automate this to the other sheets. Numbers populate columns B, C, and D, Answers should be placed in G, H and any other columns after H are empty.
Private Sub FindAndCreateSheet3dBm()
' Declare variables
Dim eWs As Worksheet
Dim rMargin As Range
Dim myUnion As Range
'Column G: subrtact max and measured values
Worksheets("page 6").Range("G1:G21").Formula = "=(C1-D1)"
'*need to fix sheet reference, make all sheets, add flexible range to
'end of G range
'Column H: subrtact measured and min values
Worksheets("page 6").Range("H1:H21").Formula = "=(D1-B1)"
'*need to fix sheet reference, make all sheets, add flexible range to
'end of H range
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Create the report sheet at first position then name it "Less than 3dBm"
Dim wsReport As Worksheet
Dim rCellwsReport As Range
Set wsReport = ThisWorkbook.Sheets.Add(Before:=ThisWorkbook.Sheets(1))
wsReport.Name = "Less than 3dBm"
Set rCellwsReport = wsReport.Cells(1, 1)
'Create union of columns to search G and H?
Set myUnion = Union(Columns("G"), Columns("H"))
'Check whole Workbook, union G and H for values less than rMargin
NextSheet:
Next
End Sub
Thank you
This should work for your needs. Before I get into my code, I just want to note that usually the response you'll get from the community when asking a 'how do I do this' question is that SO is not a code for me site. We are happy to help fix broken code, but these kinds of problems can generally be solved with Google.
That being said, I wanted a break from the project I was working on, so I threw this together. My hope here is that you can use it as a learning opportunity of how to write better code (and maybe get some kudos from your boss in the process).
Here's the code:
Private Sub FindAndCreateSheet3dBm()
' Ideally, you wouldnt even use something like this. For your purposes
' it will get you going. I highly recommend finding a dynamic way of
' determining the positions of the data. It may be consistent now, but
' in the world of programming, everything changes, especially when
' you think it wont.
Const FIRST_INPUT_COL As Long = 3 ' Column C
Const SECOND_INPUT_COL As Long = 4 ' D
Const THIRD_INPUT_COL As Long = 2 ' B
Const FIRST_OUTPUT_COL As Long = 7 ' G
Const SECOND_OUTPUT_COL As Long = 8 ' H
Dim marginReport As Worksheet
Set marginReport = ThisWorkbook.Sheets.Add(Before:=ThisWorkbook.Sheets(1))
marginReport.Name = "Less than 3dBm"
Dim targetWorksheet As Worksheet
For Each targetWorksheet In ThisWorkbook.Worksheets
If Not targetWorksheet Is marginReport Then
Dim inputData As Variant
inputData = targetWorksheet.UsedRange.value
Dim outputData As Variant
' I resize the array to be the exact same as the first, but to add two additional columns
ReDim outputData(LBound(inputData, 1) To UBound(inputData, 1), LBound(inputData, 2) To UBound(inputData, 2) + 2)
Dim i As Long
Dim j As Long
' Loop through rows
For i = LBound(inputData, 1) To UBound(inputData, 1)
' Loop through columns
For j = LBound(inputData, 2) To UBound(inputData, 2)
' Essentially, just copy the data
outputData(i, j) = inputData(i, j)
Next
Next
Dim offSetValue As Long
If LBound(outputData, 2) = 1 Then offSetValue = -1
' For your purposes I will use hardcoded indices here, but it is far more ideal to manage this in a more flexible manner
For i = LBound(outputData, 1) To UBound(outputData, 1)
outputData(i, FIRST_OUTPUT_COL) = outputData(i, FIRST_INPUT_COL) - outputData(i, SECOND_INPUT_COL)
outputData(i, SECOND_OUTPUT_COL) = outputData(i, FIRST_OUTPUT_COL) - outputData(i, THIRD_INPUT_COL)
If LessThanMargin(outputData(i, SECOND_OUTPUT_COL)) Then
For j = LBound(outputData, 2) To UBound(outputData, 2)
' I start with the output worksheet, and use the 'End(xlUp) to find the first
' non-blank row. I then iterate columnwise and add values to the row beneath it.
' The offSetValue variable ensures I am not skipping any cells if the array
' is 1-Based versus the default 0-Base.
marginReport.Range("A1048576").End(xlUp).Offset(1, j + offSetValue).value = outputData(i, j)
Next
End If
Next
OutputArray outputData, targetWorksheet, "UpdatedData_" & UCase(Replace(targetWorksheet.Name, " ", "_"))
End If
Next
End Sub
' I am just checking for a negative number here, but change this to use the logic you need
Public Function LessThanMargin(ByVal InputValue As Double)
LessThanMargin = InputValue < 0
End Function
Public Sub OutputArray(ByVal InputArray As Variant, ByVal InputWorksheet As Worksheet, ByVal TableName As String)
Dim AddLengthH As Long
Dim AddLengthW As Long
If NumberOfArrayDimensions(InputArray) = 2 Then
If LBound(InputArray, 1) = 0 Then AddLengthH = 1
If LBound(InputArray, 2) = 0 Then AddLengthW = 1
Dim r As Range
If Not InputWorksheet Is Nothing Then
With InputWorksheet
.Cells.Clear
Set r = .Range("A1").Resize(UBound(InputArray, 1) + AddLengthH, UBound(InputArray, 2) + AddLengthW)
r.value = InputArray
.ListObjects.Add(xlSrcRange, r, , xlYes).Name = TableName
With .ListObjects(1).Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End If
End If
End Sub
I use arrays to solve the problem since they are far more efficient when processing data versus using excel-formulas. While this is unlikely to make a performance boost on a ~200 row project, it makes tremendous differences when you're dealing with a few thousand rows or even more.
I also used constants for the column positions to make it easier for you to adjust these in the future. This comes with a caution though, even constants (for this purpose) are terrible habit so dont get used to them. Learn how to calculate where the data is.
Finally, please (for the love of all that is programmatic) don't just copy and paste this code and never look back. I put this up here for you (and others) to learn from it. Not for it to be some sort of quick fix. I hope you can use it to grow.
I have this macro to delete the entire rows for those that are not "chr9". I have a total of 401,094 rows. It seems to compile fine, but my Excel freezes and I have to Force Quit.
I think it may be an inefficient algorithm or maybe some error in the code?
Sub deleteNonChr9()
Dim lastrow As Long
Dim firstrow As Long
Dim i As Long
lastrow = 401094
firstrow = 0
' Increment bottom of sheet to upwards
For i = lastrow To firstrow Step -1
If (Range("C1").Offset(i, 0) <> "chr9") Then
Range("C1").Offset(i, 0).EntireRow.Delete
End If
Next i
End Sub
The fastest way to conditionally delete rows is to have them all at the bottom of the data block. Sorting them into that position and deleting is faster than individual looping or even compiling a discontiguous Union of rows to delete.
When any group or cells is contiguous (i.e. all together) Excel does not have to work as hard to get rid of them. If they are at the bottom of the Worksheet.UsedRange property, Excel doesn't have to calculate what to fill the empty space with.
Your original code did not allow for a column header text label in row 1 but I will account for that. Modify to suit if you do not have one.
These will turn off the three primary parasites of computing power. Two have already been addressed in the comments and answers, the third Application.EnableEvents property can also make a valid contribution to Sub procedure efficiency whether you have event driven routines or not. See the helper Sub procedure at the bottom for details.
Sample data²: 500K rows of random data in A:Z. ~33% Chr9 in column C:C. Approximately 333K randomly discontiguous rows to delete.
Union and delete
Option Explicit
Sub deleteByUnion()
Dim rw As Long, dels As Range
On Error GoTo bm_Safe_Exit
appTGGL bTGGL:=False 'disable parasitic environment
With Worksheets("Sheet1")
Set dels = .Cells(.Rows.Count, "C").End(xlUp).Offset(1)
For rw = .Cells(.Rows.Count, "C").End(xlUp).Row To 2 Step -1
If LCase$(.Cells(rw, "C").Value2) <> "chr9" Then
Set dels = Union(dels, .Cells(rw, "C"))
End If
Next rw
If Not dels Is Nothing Then
dels.EntireRow.Delete
End If
End With
bm_Safe_Exit:
appTGGL
End Sub
Elapsed time: <It has been 20 minutes... I'll update this when it finishes...>
Bulk load from worksheet to variant array, change, load back, sort and delete
Sub deleteByArrayAndSort()
Dim v As Long, vals As Variant
On Error GoTo bm_Safe_Exit
appTGGL bTGGL:=False 'disable parasitic environment
With Worksheets("Sheet1")
With .Cells(1, 1).CurrentRegion
.EntireRow.Hidden = False
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
'bulk load column C values
vals = .Columns(3).Value2
'change non-Chr9 values into vbNullStrings
For v = LBound(vals, 1) To UBound(vals, 1)
If LCase$(vals(v, 1)) <> "chr9" Then _
vals(v, 1) = vbNullString
Next v
End With
'dump revised array back into column C
.Cells(2, "C").Resize(UBound(vals, 1), UBound(vals, 2)) = vals
'sort all of blank C's to the bottom
.Cells.Sort Key1:=.Columns(3), Order1:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlYes
'delete non-Chr9 contiguous rows at bottom of currentregion
.Range(.Cells(.Rows.Count, "C").End(xlUp), .Cells(.Rows.Count, "C")).EntireRow.Delete
End With
.UsedRange 'reset the last_cell property
End With
bm_Safe_Exit:
appTGGL
End Sub
Elapsed time: 11.61 seconds¹ (166,262 rows of data remaining²)
Original code
Elapsed time: <still waiting...>
Summary
There are obvious advantages to working within a variant array as well as deleting contiguous ranges. My sample data had ~66% of the rows to delete so it was a harsh task master. If there were 5 or 20 rows to delete, using an array to parse data for a sort may not be the best solution. You will have to make your own decisions based on your own data.
appTGGL helper Sub procedure
Public Sub appTGGL(Optional bTGGL As Boolean = True)
With Application
.ScreenUpdating = bTGGL
.EnableEvents = bTGGL
.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
End With
Debug.Print Timer
End Sub
¹ Environment: old business class laptop with a mobile i5 and 8gbs of DRAM running WIN7 and Office 2013 (version 15.0.4805.1001 MSO 15.0.4815.1000 32-bit) - typical of the low end of the scale for performing this level of procedure.
² Sample data temporarily available at Deleting entire row cannot handle 400,000 rows.xlsb.
Toggling ScreenUpdating and Calculation will help. But as Jeeped stated, applying a custom sort order is the way to go.
Sub deleteNonChr9()
Dim lastrow As Long
Dim firstrow As Long
Dim i As Long
lastrow = 401094
firstrow = 1
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Increment bottom of sheet to upwards
For i = lastrow To firstrow Step -1
If (Cells(i, "C") <> "chr9") Then
Rows(i).EntireRow.Delete
End If
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Major Progress
The following code for dealing with deleting a very large number of rows is inspired by Ron de Bruin - Excel Automation.
Sub QuickDeleteRows()
Dim Sheet_Data As Worksheet, NewSheet_Data As Worksheet
Dim Sheet_Name As String, ZeroTime As Double, Data As Range
On Error GoTo Error_Handler
SpeedUp True
Set Sheet_Data = Sheets("Test")
Sheet_Name = Sheet_Data.Name
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
Set Data = Sheet_Data.Range("A1", Cells(LastRow, LastColumn))
Set NewSheet_Data = Sheets.Add(After:=Sheet_Data)
Data.AutoFilter Field:=3, Criteria1:="=Chr9"
Data.Copy
With NewSheet_Data.Cells
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteAll
.Cells(1, 1).Select
.Cells(1, 1).Copy
End With
Sheet_Data.Delete
NewSheet_Data.Name = Sheet_Name
Safe_Exit:
SpeedUp False
Exit Sub
Error_Handler:
Resume Safe_Exit
End Sub
Sub SpeedUp(SpeedUpOn As Boolean)
With Application
If SpeedUpOn Then
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayStatusBar = False
.DisplayAlerts = False
Else
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayStatusBar = True
.DisplayAlerts = True
End If
End With
End Sub
While my old version of code takes time rather long (about 130 seconds on average) for handling sample data provided by Jeeped, but the code above completes less than 4.6 seconds for handling 400,000 rows of sample data on my machine. It's a very significant gain in performance!
System Information of my PC (Very Minimum Computer Configurations for Students)
Operating System: Windows 7 Professional 32-bit (6.1, Build 7601)
Service Pack 1
System Manufacturer: Hewlett-Packard
System Model: HP Pro 3330 MT
Processor: Intel(R) Core(TM) i3-2120 CPU # 3.30GHz (4
CPUs), ~3.3GHz
Memory: 2048MB RAM
Original Answer
I'm aware that this answer is not really what the OP wants, but maybe this answer can be useful for other users and helpful to future users, if not the OP. Please see this answer as the alternative method.
Copy/paste, cut/insert, and delete entire row operations in Excel can take an excessively long time even when doing it in VBA Excel. For copy/paste and cut/insert operations the cause of the slowness is the formatting of the data itself. Memory over-allocation is another cause of those operations. So how do we resolve a situation like this? There are several things you can look for speeding up your code.
Use arrays instead of the range of cells. It's usually considered to be faster than working on the range of cells because it ignores the formatting of the data in cells.
Use .Value2 rather than the default property (.Value) because .Value2 will only treat all formatting numbers (currency, accounting, date, scientific, etc) as Doubles.
Suppose we have 10,000 rows of dummy data like the following dataset:
Instead of deleting entire rows of "non-chr9" data, I simply ignore those data and only consider the "chr9" data by copying all the "chr9" data into an array. How to code to implement such task? First of all, we must make a copy of our data to avoid data loss because we cannot undo all changes to recover the original data after running VBA Excel.
It seems you have done all the preparations needed. Now, we may start coding by first declaring every variable we need to the appropriate type of data.
Dim i As Long, j As Long, k As Long
Dim LastRow As Long, LastColumn As Long, LengthDataChr9 As Long
If you don't declare the variables, your code will run with those variables defaulting to the Variant type. While Variant can be enormously useful, but it can make your code slow. So, make sure each variable is declared with a sensible type. This is good programming practice and considerably faster.
Next, we determine all variables we will use to construct the size of arrays. We will need
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
LastRow and LastColumn are the row and column number of the last cell with data in one row or one column. Keep in mind, LastRow and LastColumn may not give you the desired row and column number if you are not setting them up properly or using a well-formatted data sheet. What I mean by a "well-formatted data sheet", is a worksheet with data that starts in cell A1 and the number of the rows in column A and columns in row 1 must be equal to the range of all data. In other words, the size of the range of all data must be equal to LastRowxLastColumn.
We also need the length of the array for storing all the "chr9" data. This can be done by counting all the "chr9" data using the following statement:
LengthDataChr9 = Application.CountIf(Columns("C"), "chr9")
We now know the size of the arrays and we can redimension it. Add the following code lines:
ReDim Data(1 To LastRow, 1 To LastColumn)
ReDim DataChr9(1 To LengthDataChr9, 1 To LastColumn)
We use ReDim instead of Dim because we use the dynamic arrays. VBA Excel has automatically declared the arrays defaulting to the Variant type, but they have no size yet. Next, we copy the data into the array Data by using statement
Data = Range("A1", Cells(LastRow, LastColumn)).Value2
We use .Value2 to improve the performance of the code (See speeding up tips point 2 above). Since the data has already copied to the array Data we may clear the worksheet data so we can use it to paste DataChr9.
Rows("1:" & Rows.Count).ClearContents
To clear everything (all contents, formats, etc.) on the worksheet, we may use Sheets("Sheet1").Cells.Clear or Sheet1.Cells.Clear. Next, we want the code to loop through the elements array Data in column 3 by using For ... Next statement because the desired data we're looking for are located there. If the element of array Data contains string "chr9" is found, the code then copying all the elements in the row where "chr9" is located into DataChr9. Again we use For ... Next statement. Here are the lines for implementing those procedures.
For i = 1 To UBound(Data)
If Data(i, 3) = "chr9" Then
j = j + 1
For k = 1 To LastColumn
DataChr9(j, k) = Data(i, k)
Next k
End If
Next i
where j = j + 1 is a counter for looping through the rows of DataChr9. The final step, we paste back all the elements of DataChr9 to the worksheet by adding this line to the code:
Range("A1", Cells(LengthDataChr9, LastColumn)) = DataChr9
and then you're done! Yay, finally!
OK, let's compile all the lines code above. We obtain
Sub DeleteNonChr9()
Dim i As Long, j As Long, k As Long
Dim LastRow As Long, LastColumn As Long, LengthDataChr9 As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
LengthDataChr9 = Application.CountIf(Columns("C"), "chr9")
ReDim Data(1 To LastRow, 1 To LastColumn)
ReDim DataChr9(1 To LengthDataChr9, 1 To LastColumn)
Data = Range("A1", Cells(LastRow, LastColumn)).Value2
Rows("1:" & Rows.Count).ClearContents
For i = 1 To UBound(Data)
If Data(i, 3) = "chr9" Then
j = j + 1
For k = 1 To LastColumn
DataChr9(j, k) = Data(i, k)
Next k
End If
Next i
Range("A1", Cells(LengthDataChr9, LastColumn)) = DataChr9
End Sub
The performance of the code above is satisfying. It takes less than 0.5 seconds on average to complete the process of extracting all "chr9" data from 10,000 rows dummy data on my machine.
I currently have a macro that I use to delete a record if the ID doesn't exist in a list of ID's I created from an XML document. It does work like I want it to, however I have over 1000 columns in the spreadsheet (one for each day of the year until end of 2015) so it takes ages to delete the row and it can only do 1 or 2 before it says "Excel ran out of resources and had to stop". Below is the code I'm using for the macro, is there another way I can do this so that Excel doesn't run of of resources?
Sub deleteTasks()
Application.ScreenUpdating = False
Dim search As String
Dim sheet As Worksheet
Dim cell As Range, col As Range
Set sheet = Worksheets("misc")
Set col = sheet.Columns(4)
ActiveWorkbook.Sheets("Schedule").Activate
ActiveSheet.Range("A4").Select
ActiveSheet.Unprotect
ActiveSheet.Range("A:C").EntireColumn.Hidden = False
Do While ActiveCell.Value <> ""
search = ActiveCell.Value
Set cell = col.Find(What:=search, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If cell Is Nothing Then 'If the taskID is not in the XML list
Debug.Print "Deleted Task: " & ActiveCell.Value
Selection.EntireRow.Delete
End If
ActiveCell.Offset(1, 0).Select 'Select next task ID
Loop
ActiveSheet.Range("A:B").EntireColumn.Hidden = True
ActiveSheet.Protect
End Sub
After trying lots of different options, including all the answers listed below. I have realized that whatever the method is, deleting a row with ~1100 columns is going to take a while on my average laptop (2.20 Ghz, 4GB RAM). Since the majority of the rows are empty I have found alternative method which is a lot faster. I just clear the cells which contain data (A:S) and then resize the table to remove the row where I just deleted the data from. This end result is exactly the same as entireColumn.Delete. Below is the code I'm using now
'New method - takes about 10 seconds on my laptop
Set ws = Worksheets("Schedule")
Set table = ws.ListObjects(1)
Set r = ws.Range("A280:S280")
r.Clear
table.Resize Range("A3:VZ279")
Using anything involving EntireColumn.Delete or just manually selecting the row and deleting it takes about 20-30 seconds on my laptop. Of course this method only works if your data is in a table.
The short answer:
Use something like
ActiveSheet.Range(DelStr).Delete
' where DelStr = "15:15" if you want to delete row 15
' = "15:15,20:20,32:32" if you want to delete rows 15,20 and 32
The long answer:
Important: If you have ~ 30 / 35 rows to delete, the following code works very efficiently. Beyond which it would throw up an error. For code to handle arbitrary number of rows efficiently see the very long answer below this.
If you have a function which lets you list out which rows you want to delete, try the code below. This is what I use to very efficiently delete multiple rows with minimum overhead. (the example assumes that you've obtained the rows you need to delete through some program, here I manually feed them in):
Sub DeleteRows()
Dim DelRows() As Variant
ReDim DelRows(1 To 3)
DelRows(1) = 15
DelRows(2) = 18
DelRows(3) = 21
'--- How to delete them all together?
Dim i As Long
For i = LBound(DelRows) To UBound(DelRows)
DelRows(i) = DelRows(i) & ":" & DelRows(i)
Next i
Dim DelStr As String
DelStr = Join(DelRows, ",")
' DelStr = "15:15,18:18,21:21"
'
' IMPORTANT: Range strings have a 255 character limit
' See the other code to handle very long strings
ActiveSheet.Range(DelStr).Delete
End Sub
The (very long) efficient solution for arbitrary number of rows and benchmark results:
Here are the benchmark results obtained by deleting rows (Time in seconds vs. no. of rows).
The rows are on a clean sheet and contain a volatile formula in the D column from D1:D100000
i.e. for 100,000 rows, they have a formula =SIN(RAND())
The code is long and not too pretty, but it splits the DelStr into 250 character substrings and forms a range using these. Then the new DeleteRng range is deleted in a single operation.
The time to delete may depend on the contents of the cells. The testing/benchmarking, in congruence with a bit of intuition suggests the following results.
Sparse rows/empty cells delete fastest
Cells with values take somewhat longer
Cells with formulas take even longer
Cells which feed into formulas in other cells take longest as their deletion triggers the #Ref reference error.
Code:
Sub DeleteRows()
' Usual optimization
' Events not disabled as sometimes you'll need to interrupt
' You can optionally keep them disabled
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
' Declarations...
Dim DelRows() As Variant
Dim DelStr As String, LenStr As Long
Dim CutHere_Str As String
Dim i As Long
Dim MaxRowsTest As Long
MaxRowsTest = 1000
' Here I'm taking all even rows from 1 to MaxRowsTest
' as rows to be deleted
ReDim DelRows(1 To MaxRowsTest)
For i = 1 To MaxRowsTest
DelRows(i) = i * 2
Next i
'--- How to delete them all together?
LenStr = 0
DelStr = ""
For i = LBound(DelRows) To UBound(DelRows)
LenStr = LenStr + Len(DelRows(i)) * 2 + 2
' One for a comma, one for the colon and the rest for the row number
' The goal is to create a string like
' DelStr = "15:15,18:18,21:21"
If LenStr > 200 Then
LenStr = 0
CutHere_Str = "!" ' Demarcator for long strings
Else
CutHere_Str = ""
End If
DelRows(i) = DelRows(i) & ":" & DelRows(i) & CutHere_Str
Next i
DelStr = Join(DelRows, ",")
Dim DelStr_Cut() As String
DelStr_Cut = Split(DelStr, "!,")
' Each DelStr_Cut(#) string has a usable string
Dim DeleteRng As Range
Set DeleteRng = ActiveSheet.Range(DelStr_Cut(0))
For i = LBound(DelStr_Cut) + 1 To UBound(DelStr_Cut)
Set DeleteRng = Union(DeleteRng, ActiveSheet.Range(DelStr_Cut(i)))
Next i
DeleteRng.Delete
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
The code to generate the formulas in a blank sheet is
Sub FillRandom()
ActiveSheet.Range("D1").FormulaR1C1 = "=SIN(RAND())"
Range("D1").AutoFill Destination:=Range("D1:D100000"), Type:=xlFillDefault
End Sub
And the code to generate the benchmark results above is
Sub TestTimeForDeletion()
Call FillRandom
Dim Time1 As Single, Time2 As Single
Time1 = Timer
Call DeleteRows
Time2 = Timer
MsgBox (Time2 - Time1)
End Sub
Note: Many thanks to brettdj for pointing out the error which gets thrown when the length of DelStr exceeding 255 characters. It seems to be a known problem and as I painfully found out, it still exists for Excel 2013.
This code uses AutoFilter and is significantly faster than looping through rows.I use it daily and it should be pretty easy to figure out.Just pass it what you're looking for and the column to search in.You could also hard-code the column if you want.
private sub PurgeRandy
Call FindDelete("F", "Randy")
end sub
Public Sub FindDelete(sCOL As String, vSearch As Variant) 'Simple find and Delete
Dim lLastRow As Integer
Dim rng As Range
Dim rngDelete As Range
Range(sCOL & 1).Select
[2:2].Insert
[2:2] = "***"
Range(sCOL & ":" & sCOL).Select
With ActiveSheet
.UsedRange
lLastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
Set rng = Range(sCOL & 2, Cells(lLastRow, sCOL))
rng.AutoFilter Field:=1, Criteria1:=vSearch
Set rngDelete = rng.SpecialCells(xlCellTypeVisible)
rng.AutoFilter
rngDelete.EntireRow.Delete
.UsedRange
End With
End Sub
In this case a simple working formula can be used to see if each of the values in your range to be tested (column A of schedule) exist in column F of misc
In B4 it would =MATCH(A4,misc!D:D,0)
This can be used manually or with code for an efficient delete as the formula by design returns an error if there is no match which we can efficiently delete with VBA with either:
AutoFilter
SpecialCells (the design piece*)
In xl2007 note that there is a limit of 8192 discrete areas that can be selected with SpecialCells
code
Sub ReCut()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Set ws1 = Sheets("misc")
Set ws2 = Sheets("schedule")
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Set rng1 = ws2.Range(ws2.[a4], ws2.Cells(Rows.Count, "A").End(xlUp))
ws2.Columns(2).Insert
With rng1.Offset(0, 1)
.FormulaR1C1 = "=MATCH(RC[-1],'" & ws1.Name & "'!C[2],0)"
On Error Resume Next
.Cells.SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
On Error GoTo 0
End With
ws2.Columns(2).Delete
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
Note: I don't have enough "reputation" to add my comments thus posting as answer. Credit to hnk for wonderful answer (Long Answer). I have one edit as suggestion:
Once you split the long string and in case the last block is more than the set character then it is having "!" at the end which is throwing error for range method. Addition of IF statement and MID is ensuring that there is no such character.
To handle that, use:
For i = LBound(DelStr_Cut) + 1 To UBound(DelStr_Cut)
If Right(DelStr_Cut(i), 1) = "!" Then
DelStr_Cut(i) = Mid(DelStr_Cut(i), 1, Len(DelStr_Cut(i)) - 1)
Set DeleteRng = Union(DeleteRng, ActiveSheet.Range(DelStr_Cut(i)))
Else
Set DeleteRng = Union(DeleteRng, ActiveSheet.Range(DelStr_Cut(i)))
End If
Next i
Thanks,
Bakul