Faster multiple criteria search/filter excel - vba

Hi guys I made the code below to search for multiple text in a given column. The problem is that it is very slow. Do guys know any other ways to perform it faster?
For example give the array ('foo', 'bar'), The code should iterate on a column and match/filter only the rows that have both texts in any given order.
Sub aTest()
ScreenUpdating = False
Dim selectedRange As Range, cell As Range
Dim searchValues() As String
searchValues = Split(ActiveSheet.Cells(2, 1).Value)
Set selectedRange = Range("A4:A40000")
Dim element As Variant
For Each cell In selectedRange
If cell.Value = "" Then
Exit For
Else
For Each element In searchValues
If Not InStr(1, cell.Value, element) Then
cell.EntireRow.Hidden = True
End If
Next element
End If
Next cell
ScreenUpdating = True
End Sub
I was using it as a filter. copied and pasted the following code with a few modifications. But then I was not able to make the changes to match multiple strings.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim iFilterColumn As Integer
Dim rFilter As Range
Dim sCriteria As String
On Error Resume Next
With Target
Set rFilter = .Parent.AutoFilter.Range
iFilterColumn = .Column + 1 - rFilter.Columns(1).Column
If Intersect(Target, Range("rCriteria")) Is Nothing Then GoTo Terminator
Select Case Left(.Value, 1)
Case ">", "<"
sCriteria = .Value
Case Else
sCriteria = "=*" & .Value & "*"
End Select
If sCriteria = "=" Then
.Parent.Range(rFilter.Address).AutoFilter Field:=iFilterColumn
Else
.Parent.Range(rFilter.Address).AutoFilter Field:=iFilterColumn, Criteria1:=sCriteria
End If
End With
Terminator:
Set rFilter = Nothing
On Error GoTo 0
End Sub

I'm assuming this:
Set selectedRange = Range("A4:A40000")
It's because the size is not defined properly, the following should limit to the right long
Set selectedRange = Range("A4:A" & Cells(Rows.Count, "A").End(xlUp).Row)
If it doesn't affect, I always use these codes to speed up Excel (Instead of only ScreenUpdating alone).
Sub ExcelNormal()
With Excel.Application
.Cursor = xlDefault
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
End Sub
Sub ExcelBusy()
With Excel.Application
.Cursor = xlWait
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
.StatusBar = False
End With
End Sub
Note: In the future Probably Code Review would be better place to post.

Related

Speeding up code and screen flickering using screenupdating

I have created a macro where I download data into Excel from a software database through an array formula. The scope of the macro is to input a start date and the data is written to individual Excel files and then saved away.
Unfortunately the macro is very slow although I am using the usual code lines to speed up the macro.
Another problem is that the array formula constantly expands the UsedRange with empty lines and thus the file gets bigger and bigger. To counteract this, I delete the empty lines within a For Next loop. Last but not least I still have screen flickering. My guess is the use of DoEvents but I need it for the update of the array formula.Otherwise the code will continue without having the data downloaded.
Below is my code:
Sub Update()
Dim wbTarget As Workbook
Dim objWsInput As Worksheet, objWsMakro As Worksheet, objWsDerivative, objWsFile
Dim Inbox1 As Variant
Dim strFormula As String, strFilename As String, strDate As String
Dim lngDate As Long
Dim dDay As Date
Set objWsInput = ThisWorkbook.Worksheets("INPUT")
'Input start date
Inbox1 = InputBox("Geben Sie bitte ein Start-Datum ein!", Default:=Format(Date, "DD.MM.YYYY"))
Call EventsOff
For dDay = DateSerial(Year(Inbox1), Month(Inbox1), Day(Inbox1)) To DateSerial(Year(Now), Month(Now), Day(Now))
If Weekday(dDay) <> 1 And Weekday(dDay) <> 7 Then
'Convert date into DateValue & string
strDate = Format(dDay, "YYYYMMDD")
lngDate = DateValue(dDay)
'Delete contents
With objWsInput
.Activate
.UsedRange.ClearContents
'Set array formula for QPLIX
strFormula = "=DisplayAllocationWithPreset(""5a9eb7ae2c94dee7a0d0fd5c"", ""5b06a1832c94de73b4194ccd"", " & lngDate & ")"
.Range("A1").FormulaArray = strFormula
'Wait until refresh is done
Do
DoEvents
Loop While Not Application.CalculationState = xlDone
'Copy paste
.Range("A1").CurrentRegion.Copy
.Range("A1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Call last row and delete depth 0 with number format
i = 2
Call LastRow
For i = CountRow To 2 Step -1
If .Cells(i, 1) = 0 Then .Rows(i).Delete
Next i
Call NumberFormat
'Set file name
strFilename = "Y:\Risikomanagement\Mandate Positions\QPLIX_Mandate_Positions_" & strDate & ".xlsx"
'Open file
Set wbTarget = Workbooks.Add
Set objWsFile = wbTarget.Worksheets(1)
'Copy data into new file
.Range("C1:J" & .Range("A1").CurrentRegion.Rows.Count).Copy Destination:=objWsFile.Range("A1")
'Save file
wbTarget.SaveAs Filename:=strFilename
wbTarget.Close
Call DeleteBlankRows
End With
End If
Next dDay
'Save Workbook
ActiveWorkbook.Save
Call EventsOn
MsgBox "Upload Files erstellt!", vbInformation, "Hinweis"
End Sub
The support functions are as followed:
Public Sub EventsOff()
'Events ausschalten
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
End Sub
Public Sub EventsOn()
'Events anschalten
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
End Sub
To complete my code here are the parts for deleting empty rows & formatting the numbers:
Sub DeleteBlankRows()
Dim MyRange As Range
Dim iCounter As Long
Set MyRange = ActiveSheet.UsedRange
For iCounter = MyRange.Rows.Count To 1 Step -1
'Step 4: If entire row is empty then delete it.
If Application.CountA(Rows(iCounter).EntireRow) = 0 Then
Rows(iCounter).Delete
End If
Next iCounter
End Sub
Sub NumberFormat()
Dim r As Range
For Each r In ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)
If IsNumeric(r) Then
r.Value = CDec(r.Value)
r.NumberFormat = "#,##0.00"
End If
Next r
End Sub
Any help is appreciated.Thank you in advance.
Rgds
It seems that DoEvents disables the usual speed up procedures like:
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
I changed my code including the support function Call Events Off directly after DoEvents loop and the flickering disappeared. The whole process was also much faster.

vba end if without block if

I keep getting this error, but can't figure out why. It looks like all rules are followed.
The structure as I read is the following - If -> ElseIf -> End If. But here I get an error though it's all the same.
Sub hide()
Application.ScreenUpdating = False
Dim wRange As Range
Set wRange = Range("A5:B10")
Dim mergedRows As Integer
Dim mergedColumns As Integer
Dim cellFirst As Range
For Each cell In wRange
If IsEmpty(cell) Then
cell.EntireRow.Hidden = True
ElseIf cell.MergeCells Then
mergeRows = cell.MergeArea.Rows.Count
mergeColumns = cell.MergeArea.Columns.Count
With cell.MergeArea
Set cellFirst = cell.MergeArea(Cells(1, 1))
If IsEmpty(cellFirst) Then
cellFirst.EntireRow.Hidden = True
End If
End If
Next
End Sub
You need to also close your With statement.
With cell.MergeArea
Set cellFirst = cell.MergeArea(Cells(1, 1))
If IsEmpty(cellFirst) Then
cellFirst.EntireRow.Hidden = True
End If
End With

Delete worksheet if cells are empty

This would be a very simple question.
But I am not sure why this is not working in my excel vba code.
Sheets("I- ABC").Select
If IsEmpty(Range("A3").Value) = True And _
IsEmpty(Range("A4").Value) = True And _
IsEmpty(Range("A5").Value) = True And _
IsEmpty(Range("A6").Value) = True Then
Sheets("I- ABC").Delete
End If
What type of error do you get? I tried this code and Excel displays only warning message:
You can avoid this message by adding:
Application.DisplayAlerts = False
and
Application.DisplayAlerts = True
at the beginning and at the end of your code respectively.
--Edited code
Sub Example()
Application.DisplayAlerts = False
With Sheets("I- ABC")
If Application.WorksheetFunction.CountA(.Range("A3:A6")) = 0 Then
.Delete
End If
End With
Application.DisplayAlerts = True
End Sub
Try Similiar to This
Sub Test()
Application.DisplayAlerts = False
With Sheets("Sheet1")
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
Application.DisplayAlerts = True
End Sub
PS: It works for me and deletes rows containg empty cells in `A:A``
Approach Suggested by #Tim Williams also works for me as per following code in my situation
Sub Test6()
Dim r As Range, rows As Long, i As Long
Set r = ActiveSheet.Range("A3:A6")
rows = r.rows.Count
For i = rows To 1 Step (-1)
If WorksheetFunction.CountA(r.rows(i)) = 0 Then r.rows(i).Delete
Next
End Sub
It works even if we use Application instead of WorksheetFunction
If If Application.CountA(Range("A3:A6")) = 0 Then is not working as Tim suggested then that means the cells have blank spaces or unprintable characters.
Try this
Sub Sample()
Dim pos As Long
With Sheets("I- ABC")
pos = Len(Trim(.Range("A3").Value)) + _
Len(Trim(.Range("A4").Value)) + _
Len(Trim(.Range("A5").Value)) + _
Len(Trim(.Range("A6").Value))
If pos = 0 Then
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
Else
MsgBox "The cells are not empty"
End If
End With
End Sub
With skkakkar's idea expanded.
Sub Hello()
Dim rng As Range
Application.DisplayAlerts = 0
On Error GoTo er
Set rng = Range("A3:A6").SpecialCells(xlCellTypeConstants, 23)
Exit Sub
er: MsgBox "ActiveSheet.Delete" 'delete sheet
End Sub
If the spaces are the issue, then you can try this code:
Public Sub RemoveIfEmpty()
Application.DisplayAlerts = False
With Sheets("I- ABC")
If Trim(.Range("A3") & .Range("A4") & .Range("A5") & .Range("A6")) = "" Then
.Delete
End If
End With
Application.DisplayAlerts = True
End Sub

Excel Macro works slow, how to make it faster?

Stackovwerflow community.
I do believe that this question was asked x1000 times here, but i just wasn not able to find a solution for my slow macro.
This macro serves for unhiding certain areas on worksheets if correct password was entered. What area to unhide depends on cell value. On Sheet1 i have a table that relates certain cell values to passwords.
Here's the code that i use.
1st. Part (starts on userform named "Pass" OK button click)
Private Sub CommandButton1_Click()
Dim ws As Worksheet
DoNotInclude = "PassDB"
For Each ws In ActiveWorkbook.Worksheets
If InStr(DoNotInclude, ws.Name) = 0 Then
Application.ScreenUpdating = False
Call Module1.Hide(ws)
Application.ScreenUpdating = True
End If
Next ws
End Sub
2nd Part.
Sub Hide(ws As Worksheet)
Application.Cursor = xlWait
Dim EntPass As String: EntPass = Pass.TextBox1.Value
If EntPass = Sheet1.Range("G1").Value Then ' Master-Pass, opens all
Sheet1.Visible = xlSheetVisible
ws.Unprotect Password:="Test"
ws.Cells.EntireRow.Hidden = False
Pass.Hide
Else
Dim Last As Integer: Last = Sheet1.Range("A1000").End(xlUp).Row
Dim i As Integer
For i = 2 To Last
Dim region As String: region = Sheet1.Range("A" & i).Value
Dim pswd As String: pswd = Sheet1.Range("B" & i).Value
If EntPass = pswd Then
ws.Unprotect Password:="Test"
ws.Cells.EntireRow.Hidden = False
Dim b As Integer
Dim Last2 As Integer: Last2 = ws.Range("A1000").End(xlUp).Row
For b = 2 To Last2
ws.Unprotect Password:="Test"
If ws.Range("A" & b).Value <> region Then
ws.Range("A" & b).EntireRow.Hidden = True
End If
If ws.Range("A" & b).Value = "HEADER" Then
ws.Range("A" & b).EntireRow.Hidden = False
End If
ws.Protect Password:="Test"
Next b
End If
Next i
End If
Application.Cursor = xlDefault
Sheet2.Activate
Sheet2.Select
Pass.Hide
End Sub
It works fast enough if I enter master-pass to get access to every hidden area, but if i enter cell.value related password, it takes about 5-6 minutes before macro will unhide required areas on every worksheet.
I'd be really grateful if someone could point out the reasons of slow performance and advise changes to be made in code. Just in case, i've uploaded my excel file here for your convenience.
http://www.datafilehost.com/d/d46e2817
Master-Pass is OPENALL, other passwords are "1" to "15".
Thank you in advance and best regards.
Try batching up your changes:
Dim rngShow as Range, c as range
ws.Unprotect Password:="Test" 'move this outside your loop !
For b = 2 To Last2
Set c = ws.Range("A" & b)
If c.Value = "HEADER" Then
c.EntireRow.Hidden = False
Else
If c.Value <> region Then
If rngShow is nothing then
Set rngShow = c
Else
Set rngShow=application.union(c, rngShow)
End If
End If
End If
Next b
If Not rngShow is Nothing Then rngShow.EntireRow.Hidden = False
ws.Protect Password:="Test" 'reprotect...
You might also want to toggle Application.Calculation = xlCalculationManual and Application.Calculation = xlCalculationAutomatic
You can also try moving your Application.Screenupdating code out of the loop, it's going to update for every sheet as written.
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Application.ScreenUpdating = False ''<- Here
DoNotInclude = "PassDB"
For Each ws In ActiveWorkbook.Worksheets
If InStr(DoNotInclude, ws.Name) = 0 Then
Call Module1.Hide(ws)
End If
Next ws
Application.ScreenUpdating = True ''<- Here
End Sub

Copying cell with VBA using If statement

I'm a beginner with VBA and I'm wondering how to add a IF ELSE statement to my code:
I only want to enable to copy the cells if the are filled and if they are not filled msgbox must pop-up
code:
Private Sub CommandButton3_Click()
Application.ScreenUpdating = False
Dim NextRow As Range
Sheet1.Range("F7,F10,F13,F16,F19,F22,F25,F28").Copy
Sheets("Overzicht").Select
Set NextRow = ActiveSheet.Cells(Cells.Rows.Count, 1).End(xlUp).Offset(1, 0)
NextRow.Select
Selection.PasteSpecial (xlValues), Transpose:=True
MsgBox "Invoer is opgeslagen"
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Welcome to stackoverflow.com
You have to wrap your copy code block with a for loop, IF-ELSE statement and a Boolean type variable.
Firstly, you want to iterate over your specified range of cells and make sure they are all filled
Dim allFilled As Boolean
Dim i As Long
For i = 7 To 28 Step 3
If Not IsEmpty(Sheet1.Range("F" & i)) Then
allFilled = True
Else
allFilled = False
End If
Next i
If they are you can proceed with copying-pasting and if they are not the program will show a message box: Not all the cells are filled! Cant copy
your complete code:
Sub CommandButton3_Click()
Application.ScreenUpdating = False
Dim allFilled As Boolean
Dim i As Long
For i = 7 To 28 Step 3
If Not IsEmpty(Sheet1.Range("F" & i)) Then
allFilled = True
Else
allFilled = False
End If
Next i
If allFilled Then ' = if (allFilled = true) then
Dim NextRow As Range
Sheet1.Range("F7,F10,F13,F16,F19,F22,F25,F28").Copy
Sheets("Overzicht").Select
Set NextRow = ActiveSheet.Cells(Cells.Rows.Count, 1).End(xlUp). _
Offset(1, 0)
NextRow.Select
Selection.PasteSpecial (xlValues), Transpose:=True
MsgBox "Invoer is opgeslagen"
Application.CutCopyMode = False
Application.ScreenUpdating = True
Else
MsgBox "Not all the cells are filled! Cant copy"
End If
End Sub
Update, from comments:
Yes, it's possible to execute different checks individually too, for example:
Dim allFilled As Boolean
If Not IsEmpty(Range("F7, F10, F13, F16")) And IsEmpty(Range("F8")) Then
' F7, F10, F13, F16 are not empty and F8 is empty
allFilled = True
ElseIf IsEmpty(Range("F28")) Then
' F28 empty cannot execute copy-paste
allFilled = False
Else
allFilled = False
End If