I have VBA running on an Excel sheet that translates the data in the sheet so I can import it into another application.
The below function cleans the data and removes text wrapping. This function takes a long time to run when the sheets have a large cell count. Since I am normalizing data to import to a relational database, there are frequently a lot of cells across the seven different sheets I have.
Is there a more efficient way to remove the text wrap and clean the data in the cells?
Dim ws As Worksheet
Dim x, lrow, lcol, active As Long
Dim r, cel As Range
active = ActiveWorkbook.Worksheets.count
For x = 1 To active
Set ws = ThisWorkbook.Sheets(x)
ws.Select
Select Case ws.name
Case "Solution", "Description", "Problem", "Buyer", "ProjectType", "Process", "Feature"
lrow = ws.UsedRange.Rows(ActiveSheet.UsedRange.Rows.count).row
lcol = ws.UsedRange.Columns(ActiveSheet.UsedRange.Rows.count).Column
If lrow > 1 Then
Set r = ws.Range(Cells(2, 1), Cells(lrow, lcol))
For Each cel In r.Cells
cel.WrapText = False
cel.Value = Application.WorksheetFunction.Clean(cel.Value)
Next cel
End If
Case Else
End Select
ws.Cells(1, 1).Select
ThisWorkbook.Sheets("Solution").Activate
Next x
Your code can be reduced to
Sub Demo()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Select Case ws.Name
Case "Solution", "Description", "Problem", "Buyer", "ProjectType", "Process", "Feature"
With ws.UsedRange
.WrapText = False
.Value = ws.Evaluate("Clean(" & .Address & ")")
End With
End Select
Next
End Sub
On my hardware, a sheet with 100,000 rows 26 columns ran in about 6s
Note: OPs claim (in comment) that "it changes the value of every cell on the sheet to the first value in the first sheet it encounters." - tested this claim and it's not accurate. This code works as advertised.
To remove the text wrapping property (and it surprises me that has an affect on your external program), you should be able to do just:
r.WrapText = False
For the Clean, what, exactly, is in the cells that you are trying to remove?
It would be faster to read the cells into an array; process them, and write them back.
Something like: (not debugged)
Dim V, I as long, J as Long
v = R
for i = 1 to ubound(v)
for j = 1 to ubound(v,2)
`worksheetfunction.clean(v(i,j))
`or some other function to remove unwanted characters
next j
next i
r.clear
r.value = v
You should also be aware that UsedRange is not particularly reliable and may wind up with you processing many more cells than necessary.
There are a number of posts on this forum showing better methods of determing the Last Row and Last Column.
Related
I am attempting to edit my code because although it functions as needed, I know it is not efficient. I am copying 5 merged cells at a time and pasting copied data in the column to the left before clearing the copied range.
Every 6th cell is skipped because it does not apply to what needs to be moved. A snippet is below, I know there is a much more efficient way to do what I am doing here, but I am brand new and have basically no experience in declaring variables or utilizing loops, functions, etc.
Thanks in advance!
Option Explicit
Sub ShiftWeeks()
Dim answer As VbMsgBoxResult
answer = MsgBox("Are you sure you want to copy/paste this weeks data?", vbYesNo, "Press Button for Macro")
If answer = vbYes Then
Range("c3:c8").Copy
Range("b3:b8").PasteSpecial xlPasteValues
Range("c3:c8").ClearContents
Range("c10:c15").Copy
Range("b10:b15").PasteSpecial xlPasteValues
Range("c10:c15").ClearContents
Range("c17:c22").Copy
Range("b17:b22").PasteSpecial xlPasteValues
Range("c17:c22").ClearContents
Range("c24:c29").Copy
Range("b24:b29").PasteSpecial xlPasteValues
Range("c24:c29").ClearContents
End If
End Sub
I've copied the same 3 code blocks quite a few times and have just changed the range. The button I made works, but I know the code is junk and it's not that difficult, but I don't know how to clean it up.
Not to nit-pick but it looks like you're actually copying 6 rows at a time, not 5 (e.g. C3:C8 is six rows). Following the same pattern you have above, you could use a For x = y to z step a -style loop, like below. If the last row will always be the same, you could define it with a lastRow = y statement, otherwise you can determine it dynamically with something like lastRow = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row.
For x = 3 To lastRow Step 7
ws.Range(ws.Cells(x, 3), ws.Cells(x + 5, 3)).Copy
ws.Range(ws.Cells(x, 2), ws.Cells(x + 5, 2)).PasteSpecial xlPasteValues
ws.Range(ws.Cells(x, 3), ws.Cells(x + 5, 3)).ClearContents
Next x
Looping
If you need to add a dozen more ranges, having to repeat lines of code per range is tedious and will quickly become unmanageable. To avoid this issue, you can change the code into a loop.
There are two ways to create the loop.
By blocks:
Sub Example()
For r = 3 To 24 Step 7
With Cells(r, 3).Resize(6)
.Offset(0, -1).Value = .Value
.ClearContents
End With
Next
End Sub
And by cells:
Sub Example()
Dim Cell As Range
For Each Cell In Range("c3:c8,c10:c15,c17:c22,c24:c29")
With Cell
.Offset(0, -1).Value = .Value
.ClearContents
End With
Next
End Sub
In the Block loop, we define the starting locations (r=3 and Cells ColumnIndex:=3) and then the block size (Step 7 and Resize(6)). In the Cells loop we simply define the range we want to operate within and execute the desired actions on every cell within that range.
In both methods, adding new locations to the macro would be as simple as changing the For loop statement line. Either by increasing the ending number from 24 or by adding more addresses to the Range.
Clipboard Copying
The clipboard is not a native feature of Excel and is actually a part of Windows. This means that when you use .Copy and .PasteSpecial in seperate lines, Excel has to communicate with windows and share the data. This is significantly slower than having the data stay within Excel. This issue is avoided by doing Range2.Value = Range1.Value and directly assigning the data without using the clipboard. You can also do Range1.Copy Destination:=Range2 but this will copy over the formatting as well as the values.
Additional Improvements
If you test out the cells loop, you'll notice that the application stutters and can be quite slow. To avoid this, you'll want to temporarily disable automatic actions by the application so that it doesn't pause during each loop. The application wants to re-calculate the sheet after every change and refresh the screen to display new values. Both of these are the cause of the stuttering and disabling them during the macro will speed things up significantly.
Sub Example()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
''''''''''''''''
'Code goes here'
''''''''''''''''
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Copy Merged Ranges
Option Explicit
Sub ShiftWeeks()
Const wsName As String = "Sheet1"
Const fRow As Long = 3
Const sCol As String = "C"
Const cOffset As Long = -1
Const rOffset As Long = 7 ' needed only for the second solution
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim answer As VbMsgBoxResult
answer = MsgBox("Are you sure you want to copy/paste this weeks data?", vbYesNo, "Press Button for Macro")
If answer = vbYes Then
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, sCol).End(xlUp).Row
If lRow < fRow Then Exit Sub ' no data
' 1.) If the rows between the merged ranges are empty...
Dim srg As Range: Set srg = ws.Cells(fRow, sCol).Resize(lRow - fRow + 1)
srg.Offset(, cOffset).Value = srg.Value
srg.Value = Empty
' 2.) ... otherwise:
' Dim sCell As Range
' Dim r As Long
'
' For r = fRow To lRow Step rOffset
' Set sCell = ws.Cells(r, sCol)
' sCell.Offset(, cOffset).Value = sCell.Value
' sCell.Value = Empty
' 'sCell.MergeArea.ClearContents
' Next r
End If
End Sub
I've built this code, and it's working fine. However I expect there must be a more elegant way to embed the range 'c' into the Evaluate function rather than how I've used 'r' to determine the row number, and build that into the reference.
(I'm learning). Copy of (very stripped down) xlsm available here: https://www.dropbox.com/s/e6pcugqs4zizfgn/2018-11-28%20-%20Hide%20table%20rows.xlsm?dl=0
Sub HideTableRows()
Application.ScreenUpdating = False
Dim c As Range
Dim r As Integer
For Each c In Range("ForecastTable[[Group]:[Item]]").Rows
r = c.Row
If Application.Evaluate("=COUNTA(B" & r & ":D" & r & ") = 0") = True Then
c.EntireRow.Hidden = True
Else: c.EntireRow.Hidden = False
End If
Next c
Application.ScreenUpdating = True
End Sub
There's no specific question/problem, but here's my suggested code improvements.
Most notably, I wouldn't execute the Hidden procedure until you have all the rows. That way you don't have repeatedly do something that only need be completed once. This will always be the best practice when looping and manipulating data. Make changes to the sheet AFTER you have identified the range.
With the above change, you don't need to turn off ScreenUpdating.
The Evaluate function is fine, but isEmpty is probably the best option. There are probably slightly faster methods, perhaps checking multiple if-statements, but that's getting into fractions of a second over thousands of rows (probably not worth researching).
Technically you don't really need to loop by rows. You can get by with a single cell in a row, then checking the next two over, see utilization of Offset to generate that range. This also creates a more dynamic than using hard-coded columns ("A"/"B"...etc")
Long is recommended over Integer but this is pretty small, and I'm only mentioning it because I posted about it here.. Technically you don't even need it with the above changes.
Here's the code:
Sub HideTableRows()
Dim c As Range, hIdeRNG As Range, WS As Worksheet
'based on OP xlsm file.
Set WS = Sheet4
'used range outside of used range to avoid an if-statement on every row
Set hIdeRNG = WS.Cells(Rows.Count, 1)
'loops through range of single cells for faster speed
For Each c In Range("ForecastTable[Group]").Cells
If IsEmpty(Range(c, c.Offset(0, 2))) = 0 Then
'only need a single member in the row.
Set hIdeRNG = Union(hIdeRNG, c)
End If
Next c
'Hides rows only if found more than 1 cell in loop
If hIdeRNG.Cells.Count > 1 Then
Intersect(WS.UsedRange, hIdeRNG).EntireRow.Hidden = True
End If
End Sub
Final Thought: There's some major enhancements coming out to Excel supposedly in early 2019 that might be useful for this type of situation if you were looking for a non-VBA solution. Click here for more info from MS.
Flipping the logic a bit, why not just filter those three columns for blanks, then hide all the visible filtered blank rows in one go?
Something like this:
Sub DoTheHide()
Dim myTable As ListObject
Set myTable = Sheet4.ListObjects("ForecastTable")
With myTable.Range
.AutoFilter Field:=1, Criteria1:="="
.AutoFilter Field:=2, Criteria1:="="
.AutoFilter Field:=3, Criteria1:="="
End With
Dim rowsToHide As Range
On Error Resume Next
Set rowsToHide = myTable.DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
myTable.AutoFilter.ShowAllData
If Not rowsToHide Is Nothing Then
rowsToHide.EntireRow.Hidden = True
End If
End Sub
Since c is used to iterate over the rows and each row contains the 3 cells in question ("=COUNTA(B" & r & ":D" & r & ") = 0") is equivalent to ("=COUNTA(" & c.Address & ") = 0"). But using the WorksheetFunction directly is a better appraoch.
It should be noted that Range("[Table]") will return the proper result as long as the table is in the ActiveWorkbook. It would be better to useThisWorkbook.Worksheets("Sheet1").Range("[Table]")`.
Sub HideTableRows()
Application.ScreenUpdating = False
Dim row As Range, target As Range
With Range("ForecastTable[[Group]:[Item]]")
.EntireRow.Hidden = False
For Each row In .rows
If Application.WorksheetFunction.CountA(row) = 0 Then
If target Is Nothing Then
Set target = row
Else
Set target = Union(target, row)
End If
End If
Next
End With
If Not target Is Nothing Then target.EntireRow.Hidden = True
Application.ScreenUpdating = True
End Sub
This question already has answers here:
How to find out if an entire row is blank in excel thorough vba
(2 answers)
Closed 4 years ago.
In my macro, I want to delete completely blank Rows. Not Rows that has something in one column because that is still valuable information.
I have looked all over the internet but if someone could come up with a function that deletes ENTIRELY blank rows and not just rows with something missing in a few columns that would be awesome.
(Information is only on Columns A through N and roughly 7 thousand rows). I haven't developed any code for this because I am really stumped.
You can use this...
Sub ClearEmptyRows()
Dim r As Long, lastrow As Long, WS As Worksheet, killRng As Range
Set WS = ActiveSheet
lastrow = WS.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Set killRng = WS.Rows(Rows.Count)
For r = 1 To lastrow
If Application.WorksheetFunction.CountA(WS.Rows(r)) = 0 Then
Set killRng = Union(killRng, WS.Rows(r))
End If
Next r
killRng.Delete
End Sub
A couple comments on this code for newbies as it's a common routine to loop through rows and do something (delete, highlight, hide, etc.)
It's always best to interact with Worksheet as infrequently as possible. Thus we execute the Delete AFTER all of the rows have been identified.
You can't Union an empty range, so I set the killRng to initially be the entire last row (hopefully this is always blank), and then the macro can proceed with Union. One could get around this by including an if-statement, but this requires the macro check if range exists on each row.
If you just want to remove empty rows and are not concerned about formatting this is super fast.
Sub RemoveEmptyRows()
Dim results As Variant, Target As Range
Dim c As Long, r As Long, n As Long
Set Target = Worksheets("Sheet1").UsedRange
If Target.Count > 0 Then
ReDim results(1 To Target.Rows.Count, 1 To Target.Columns.Count)
For r = 1 To Target.Rows.Count
If WorksheetFunction.CountA(Target.Rows(r)) > 0 Then
For c = 1 To Target.Columns.Count
n = n + 1
results(n, c) = Target.Cells(r, c).Value
Next
End If
Next
End If
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Target.Value = results
Application.ScreenUpdating = xlCalculationAutomatic
Application.ScreenUpdating = False
End Sub
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