Excel vba excessive run time, but no issues using step into - vba

I have some code to delete duplicate rows while keeping the first instance the particular string appears.
When I step into the code to delete duplicates, the macro runs without a hitch. However, once I hit run macro, my excel freezes and stops responding. I'm not quite sure why...
If anyone could shed some light. That would be greatly appreciated. (Also I added a breakline to show where I attempt to run to).
Sub CleanUp()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim lastRow As Integer
Dim i As Integer, j As Integer, k As Integer
Dim stakedItem As String
Dim sortCell As Range, allCell As Range, sortcell2 As Range
Dim currentItem As String, baseItem As String
lastRow = Sheet2.Range("A" & Sheet2.Rows.Count).End(xlUp).Row
Set sortCell = Sheet2.Range("A1")
Set sortcell2 = Sheet2.Range("B1")
Set allCell = Sheet2.Range("A1:Z" & lastRow + 1)
baseItem = Sheet2.Range("B2")
allCell.Sort key1:=sortcell2, order1:=xlAscending, Header:=xlYes
For i = 3 To lastRow
currentItem = Sheet2.Range("B" & i)
If currentItem = baseItem Then
Sheet2.Rows(i).Delete
i = i - 1
lastRow = lastRow - 1
Else
baseItem = Sheet2.Range("B" & i)
End If
Next i
Breakline here...
allCell.AutoFilter field:=2, Criteria1:=Array("*G*", "*HUB*"), Operator:=xlFilterValues
allCell.Sort key1:=sortCell, order1:=xlAscending, Header:=xlYes
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Thank you!
Francis

This will never exit if it finds a row to delete. The reason is that in a For loop, the exit condition is fixed when that line of code evaluates. That means lastRow will always be whatever it was when you entered the loop.
This code illustrates:
Sub example()
Dim x As Long, i As Long
x = 5
For i = 1 To x
Debug.Print i 'This runs 5 times...
x = 1 '...even though you change x here.
Next
End Sub
So, the only thing lastRow = lastRow - 1 does is decrement the variable. After you've deleted the first row, you're guaranteed that at the end of the sheet that currentItem = BaseItem. And inside that condition, you decrement the loop counter, which gives you an infinite loop.
As #TimWilliams mentions in the comments, you should loop backward if you are deleting rows. Something like this:
For i = lastRow To 3 Step -1
currentItem = Sheet2.Range("B" & i)
If currentItem = BaseItem Then
Sheet2.Rows(i).Delete
Else
BaseItem = Sheet2.Range("B" & i)
End If
Next i

Related

How to combine multiple macros and excel functions into a single macro that executes on button click?

I need to combine multiple macros to a single macro that executes on button click. Kindly excuse me if I write anything wrong since I am completely new to excel macros and vb.
Following is the scenario.
Steps:
Calculate total
Extract reference
Compare total field value for matching reference and mark that as "Complete" if sum of total for matching references calculates to ).
(Explained...)
First i calculate the debit and credit amount to a new column called total, for this, initially I used the SUM function. after that I tried the same using the macro that executes on button click
(old macro)
Private Sub getTotal_Click()
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 5 To lastRow
Range("K" & i).Value = Range("F" & i).Value + Range("G" & i).Value
Next i
End Sub
This was so much time consuming (took around 2 hrs when executed on 75k records) than when using the formula (which finished in minutes). I am still not able to understand the reason for this. However modifiying to Dy.Lee's answer below, it took only seconds to calculate the total.
(modified based on Dy.Lee's answer)
Private Sub getTotal_Click()
Dim vDB As Variant, vR() As Variant
Dim i As Long, n As Long, lastRow As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
vDB = .Range("R5", "S" & lastRow)
n = UBound(vDB, 1)
ReDim vR(1 To n, 1 To 1)
For i = 1 To n
vR(i, 1) = vDB(i, 1) + vDB(i, 2)
Next i
.Range("AL5").Resize(n) = vR
End With
End Sub
Now moving on to the second macro which I used to extract a pattern from strings in a column D and E.
Function extractReference(cid_No As String, pm_source As String)
Dim regExp As Object, findMatches As Object, match As Object
Dim init_result As String: init_result = ""
Set regExp = CreateObject("vbscript.regexp")
With regExp
.Global = True
.MultiLine = False
.Pattern = "(?:^|\D)(\d{5,6})(?!\d)"
End With
Set findMatches = regExp.Execute(pm_source)
For Each match In findMatches
init_result = init_result + match.SubMatches.Item(0)
Next
If init_result <> "" Then
extractReference = cid_No & " | " & init_result
Else
extractReference = ""
End If
End Function
This macro was working fine.
Finally I used the following function after copying both the extracted reference and total to a new sheet and creating a datatable for that
=IF(ISBLANK([#Reference]), "", (IF((ROUND(SUMIFS([Total],[Reference],[#Reference]),2)=0), "complete", "")))
This also worked fine.
Now what I actually want is I need to avoid creating any new data tables or sheets and preform all this within current sheet on a single button click. Is there anyway that can be done without making the macro a time consuming process? Your help is higly appreciated!
Thanks in Advance
for the first part try:
Private Sub getTotal_Click()
Dim lastRow As Long
Dim sumRange As Range
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Set sumRange = Range(Range("K5"), Range("K" & lastRow))
sumRange.FormulaR1C1 = "=RC[-5]+RC[-4]"
sumRange.Copy
sumRange.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
also, if you still want to loop notice that calling cell like .Cells(1, 1) is faster than Range("A1")
You need using Variant Array. It is faster.
Private Sub getTotal_Click()
Dim vDB As Variant, vR() As Variant
Dim i As Long, n As Long, lastRow As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
vDB = .Range("f5", "g" & lastRow)
n = UBound(vDB, 1)
ReDim vR(1 To n, 1 To 1)
For i = 1 To n
vR(i, 1) = vDB(i, 1) + vDB(i, 2)
Next i
.Range("k5").Resize(n) = vR
End With
End Sub

VBA Is searching through cells faster with Find method or going through every cell?

I've created a VBA macro in Excel that looks for all the instances of specific function in all the worksheets. I've been able to successfully create it, but I'm trying to see what is the best method performance wise give the function I'm searching for could potentially used a large amount of times with a large workbook.
I've used two methods.
Method 1 - Loop through each individual cell and using the "instr" function to see if the cell formula contains thee function.
Method 2 - Use the Find and FindNext methods along with a do loop to only loop through the cells that actually have a function.
I was surprised to find when there are a large number of functions Method 1 is a lot faster (when there are very little method 2 works faster).
Can anyone explain how that could be?
Here's a sample with an example of my code.
On "Sheet1" I've placed a user defined function named "MyFunction" in cells A1:J5000. Then in cells A5001:J10000 I've left them blank, but have colored them yellow to force the used range to be A1:J10000.
Even though Method 1 is looping through every 100,000 cells it is a lot faster than method 2 which only loops through the 50,000 cells found
Method 1 average run is about 171 ms and Method 2 average run is about 1,531 ms.
Example of my code for Method 1 and Method 2:
Method 1
Private Sub TestMethod1()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim MySheet As Worksheet, MyRange As Range, MyCell As Range
Dim MyCellAddress As String, MyCellFormula As String, MyFunction As String
Dim CountTotalCells As Long, CountTotalFunctions As Long
Dim sw, swEndTime As Long
Set sw = New StopWatch
sw.StartTimer
MyFunction = "=MyFunction("
CountTotalCells = 0
CountTotalFunctions = 0
Set MySheet = Sheets("Forum Question")
Set MyRange = MySheet.UsedRange
For Each MyCell In MyRange
MyCellFormula = MyCell.Formula
CountTotalCells = CountTotalCells + 1
If InStr(1, MyCellFormula, MyFunction) > 0 Then
CountTotalFunctions = CountTotalFunctions + 1
End If
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
swEndTime = sw.EndTimer
MsgBox CountTotalCells & ", " & CountTotalFunctions & ", " & swEndTime & " ms"
End Sub
Method 2
Private Sub TestMethod2()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim MySheet As Worksheet, MyRange As Range, MyCell As Range
Dim MyCellAddress As String, MyCellFormula As String, MyFunction As String, MyCellFirst As String
Dim CountTotalCells As Long, CountTotalFunctions As Long
Dim sw, swEndTime As Long
Set sw = New StopWatch
sw.StartTimer
MyFunction = "=MyFunction("
CountTotalCells = 0
CountTotalFunctions = 0
Set MySheet = Sheets("Forum Question")
Set MyRange = MySheet.UsedRange
Set MyCell = MyRange.Cells.Find( _
What:=MyFunction, _
After:=[A1], _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlRows, _
SearchDirection:=xlNext, _
MatchCase:=True _
)
If Not MyCell Is Nothing Then
MyCellFirst = MyCell.Address
Do
Set MyCell = MyRange.FindNext(After:=MyCell)
MyCellAddress = MyCell.Address
MyCellFormula = "z" & MyCell.Formula
CountTotalCells = CountTotalCells + 1
If InStr(1, MyCellFormula, MyFunction) > 0 Then
CountTotalFunctions = CountTotalFunctions + 1
End If
If MyCell Is Nothing Or MyCellAddress = MyCellFirst Then
Exit Do
End If
Loop
End If
Set MyCell = Nothing
swEndTime = sw.EndTimer
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox CountTotalCells & ", " & CountTotalFunctions & ", " & swEndTime & " ms"
End Sub
Let's break down the code. Both modules are looping through every cell and testing to see what formula is in the cell. You only see that in your method 1, but Excel is also check every cell in the target Range when it evaluates the call to .Find.
Let's count the function calls that touch the Worksheet in each loop. Method 1 has exactly 1:
MyCell.Formula
Method 2 has the following:
MyRange.FindNext
MyCell.Address
MyCell.Formula
...plus these comparisons...
MyCell Is Nothing
MyCellAddress = MyCellFirst
...plus this string concatenation:
MyCellFormula = "z" & MyCell.Formula
So let's add up the damage. I took the liberty of adding profiling code to test the total time spent on each of those lines (with a much larger sample or cells):
Set MyCell = MyRange.Cells.Find: 0 seconds
MyCellFirst = MyCell.Address: 0.421875 seconds
Set MyCell = MyRange.FindNext(After:=MyCell): 4.3125 seconds
MyCellFormula = "z" & MyCell.Formula: 0.34375 seconds
If MyCell Is Nothing Or MyCellAddress = MyCellFirst Then Exit Do: 0.015625 seconds
So, the big performace hog is .FindNext, which isn't surprising. It's doing a ton of work internally that is flat out skipped in Method 1 (just evaluating the 7 parameters alone...), which does simple retrievals and value string comparisons.

Finding the LastRow in multiple column ranges?

I'm trying to find the LastRow in multiple column ranges ignoring certain columns... I have two attempts but can't get either working correctly:
BOTH Examples are ignoring columns N and O
My first attempt is the following, however it doesn't get the correct last range, if I have something in A15 for example and T10, it thinks the last row is 10 when it should be 15.
Sub LastRowMacro()
LastRowString = "A1:M" & Rows.Count & ", P1:Z" & Rows.Count
LastRowTest = Range(LastRowString).Find(What:="*", After:=[A1], SearchOrder:=xlByRows, searchDirection:=xlPrevious).Row
End Sub
My second attempt is as follows, but it seems rather long winded.
Sub LastRowMacro()
Dim i As Long
LastRow = 1
IgnoreColumnList = "N;O"
For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
ColumnLetter = Split(Cells(1, i).Address(True, False), "$")(0)
For Each varFind In Split(IgnoreColumnList, ";")
If varFind = ColumnLetter Then
varNotFound = False
Exit For
End If
varNotFound = True
Next
If varNotFound Then
CurrentLastRow = Cells(Rows.Count, i).End(xlUp).Row
If CurrentLastRow >= LastRow Then
LastRow = CurrentLastRow
End If
varNotFound = False
End If
Next
End Sub
Ideally I'd like my first attempt to work however if it just doesn't work then someone surely can improve my second version...
Try this
*There is an ignoreList variable with all the columns that you want to ignore. Make sure you populate this correctly - currently ignoring N, O, P
*You may need to set the sh variable to the correct sheet - currently it's Sheet1
*btw. this snippet will always find the last last row on the spreadsheet. you can add another elseif to check whether there are 2 columns with the same high last row in case there was 2 columns with the highest lastRows.
Sub FindingLastRow() ' ignoring some columns
Dim ignoreList
ignoreList = Array("N", "O", "P") ' MODIFY IGNORE LIST
Dim sh As Worksheet
Set sh = Sheet1 ' SET CORRECT SHEET
Dim currentlast As Range
Set currentlast = sh.Cells(1, 1)
Dim iteratingCell As Range
With sh
For j = 1 To .UsedRange.Columns.Count
Set iteratingCell = .Cells(1, j)
If Not isIgnored(iteratingCell, ignoreList) Then
If iteratingCell.Cells(Rows.Count).End(xlUp).Row >= currentlast.Cells(Rows.Count).End(xlUp).Row Then
Set currentlast = iteratingCell
End If
End If
Next
Set currentlast = .Range("$" & Split(currentlast.Address, "$")(1) & "$" & currentlast.Cells(Rows.Count).End(xlUp).Row)
End With
MsgBox currentlast.Address
End Sub
Function isIgnored(currentlast As Range, ignoreList As Variant) As Boolean
Dim ignore As Boolean
Dim letter As Variant
For Each letter In ignoreList
If StrComp(Split(currentlast.Address, "$")(1), letter, vbTextCompare) = 0 Then
ignore = True
Exit For
End If
Next
isIgnored = ignore
End Function

Efficient way to delete entire row if cell doesn't contain '#' [duplicate]

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

Is it possible to get a % of (name)/total using VBA?

I was wondering if anyone knows how to get a % of say dctest/In using VBA excel?
dctest for this example is just some tested perimeter while the In can be considered as the total number of devices set to do the dc test.
I have provided an image for better understanding. Both set of results shown are before and after converting the values into %. What i'm required will be finding the % of all tests except for test1-test6. The denominator will be values of In, ie, dctest/In.
I have tried some coding, but am not very sure of how to get the percentage of the values.
Sub macro1()
Dim testrow As Long, testcell As Range, lastrowval As Long
testrow = 1 'initialise
Do
Set testcell = Sheets("Summary").Cells(testrow, 1)
'To look for any test1-test6, if there is do nothing
If testcell = "test1" Or testcell = "test2" Or testcell = "test3" Or testcell = "test4" Or testcell = "test5" Or testcell = "test6" Then
'Do nothing
Exit Do
End If
testrow = testrow + 1
Loop
Do
Set testcell = Sheets("Summary").Cells(testrow, 1)
If testcell = "Resultant" Then
lastrowval = testrow
Exit Do
End If
testrow = testrow + 1
Loop
End Sub
Do take note that, I'm aware of the use of the fixed formula that excel can do, but at times some of the tests such as ACtest will not be there OR there will be an extra test such as morning test, this will affect the fixed formula.
Do take note also that test1 - test6, sometimes all 6 tests will be present, at times only 1 test will be present.
What my concern is if there is an extra test say test1 added in, the row from dctest..... Resultant will be shifted down by 1 row.
And if there is a test say test6 got removed, the row from dctest.... resultant will be shifted up by 1 row. I'm not very sure what can be done to make sure this issues can be solved.
Follow up
I have taken the same example as shown in the picture. Like your previous question, you can either use a formula or a code.
Formula
In Cell J7, enter this formula and then right click on the cell to format as %age.
=OFFSET(INDIRECT(ADDRESS(INDEX(MATCH(I7,$A$1:$A$11,0),1,0),1,1,1)),0,1)/$B$1
If you need then simply copy the formula down
Code
Sub Sample()
With Range("J7")
.FormulaR1C1 = _
"=OFFSET(INDIRECT(ADDRESS(INDEX(MATCH(RC[-1],R1C1:R11C1,0),1,0),1,1,1)),0,1)/R1C2"
.NumberFormat = "0.00%"
End With
End Sub
OR
Sub Sample()
With Range("J7")
.Formula = _
"=OFFSET(INDIRECT(ADDRESS(INDEX(MATCH(I7,$A$1:$A$11,0),1,0),1,1,1)),0,1)/$B$1"
.NumberFormat = "0.00%"
End With
End Sub
FOLLOWUP
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim SearchText As String, Excludetext As String
Dim LastRow As Long, i As Long, j As Long
Dim MyArray() As String
Dim boolContinue As Boolean
'~~> Add/Remove the text here which you want to ignore
Excludetext = "In,Test1,Test2,Test3,Test4,Test5,Test6"
MyArray = Split(Excludetext, ",")
Set ws = Sheets("Sheet1")
LastRow = ws.Range("I" & Rows.Count).End(xlUp).Row
For i = 1 To LastRow
boolContinue = True
For j = 0 To UBound(MyArray)
SearchText = Ucase(Trim(MyArray(j)))
If Ucase(Trim(ws.Range("I" & i).Value)) = SearchText Then
boolContinue = False
Exit For
End If
Next j
If boolContinue = True Then
With Range("J" & i)
.Formula = _
"=OFFSET(INDIRECT(ADDRESS(INDEX(MATCH(I" & i & _
",$A$1:$A$11,0),1,0),1,1,1)),0,1)/$B$1"
.NumberFormat = "0.00%"
End With
End If
Next i
End Sub
HTH
Sid
Why don't you just turn it into a percent part/whole=x/100