VBA optimisation - takes too long to process

F

Fredoub20

New Member
Joined
Oct 31, 2021
Messages
10
Office Version
  1. 2013
Platform
  1. Windows
Hi guys! first time posting here.
I'm french canadian so sorry about my poor english.

So basically i wanna make like a little database on Excel with notes/jurisprudence/doctrine/laws and for every entry that i add on this sheet, i'm giving the notes/jurisprudence/doctrine/laws a tag on the column named tags. It looks like that :
1635688902761.png


First i wanted to sort the column by tags but the way i entered the tags it gave me only this option, and i knew i couldnt do it without VBA.
1635688963626.png



1635689157816.png


So after a couple hours of searching i made a button called "Rechercher" (Search) and a button "Reset". I click on the button "Search" after i've entered up to 4 criteria (i.e. tags) in the "#1, #2, #3, #4" spaces on top of the sheet. When i click "Search", this is what it does :

1635689135094.png


1635689191054.png


The thing is it's lagging so much when i click the button and it takes like 10 seconds to do what i want it to do. Can i optimise the code in a way or is my method of filtering the tags separated by comma too complicated ?

Thanks a lot in advance !

Also i have another problem i'm gonna throw in there. I wanna fit the size of the cells to match the text inside of it, but even if i click there ...
1635689351780.png

...or if i use the button "AutoFit Row Height", it doesnt work.
Anything to work around that ?

Thanks :)

Fred
 
Sort by date Sort by votes
GWteB said:
I see, replace this line within the CustomSearch procedure
VBA Code: 
        Set Rng = .Range("A3", Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count))

with this one
VBA Code: 
        Set Rng = .Range("G3:G" & .Cells(.Rows.Count, "G").End(xlUp).Row)



Thought you already had a macro for that. Nevertheless, it can be done by having no search arguments at all when the CustomSearch is invoked, or with this macro

VBA Code: 
Public Sub Reset()
    Dim Sht As Worksheet
    Set Sht = ThisWorkbook.Worksheets("Sheet1")     ' <<< change sheet name to suit
    Sht.Cells.EntireRow.Hidden = False
End Sub
Click to expand...

If i change the line you just sent me it gives me an error at the line

SQL: 
    For i = 2 To UBound(arr, 2) Step 2

SQL: 
Public Sub CustomSearch()

    Dim Sht As Worksheet
    Set Sht = ThisWorkbook.Worksheets("RÉSUMÉ")     ' <<< change sheet name to suit
      
    With Sht
        Dim Rng As Range
        Set Rng = .Range("G3:G" & .Cells(.Rows.Count, "G").End(xlUp).Row)
        Dim arr As Variant
        arr = Rng.Offset(-2).Resize(1)
    End With
    
    Application.ScreenUpdating = False
    Rng.EntireRow.Hidden = False
    
    Dim i As Long
    For i = 2 To UBound(arr, 2) Step 2
        Dim c As Range, Result As Range
        Set c = FindSomeText(arr(1, i), Rng)
        If Not c Is Nothing Then
            If Result Is Nothing Then
                Set Result = c
            Else
                Set Result = Application.Union(Result, c)
            End If
        End If
    Next i
    If Not Result Is Nothing Then
        Rng.EntireRow.Hidden = True
        Result.EntireRow.Hidden = False
    End If
    Application.ScreenUpdating = True
End Sub


Public Function FindSomeText(ByVal argText As String, ByVal argRng As Range) As Range
    Dim c As Range, StartAddr As String
    If Len(argText) > 0 Then
        Set c = argRng.Find(argText, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False, SearchOrder:=xlByRows)
        If Not c Is Nothing Then
            StartAddr = c.Address
            Do
                If FindSomeText Is Nothing Then
                    Set FindSomeText = c
                Else
                    Set FindSomeText = Application.Union(FindSomeText, c)
                End If
                Set c = argRng.FindNext(c)
            Loop While Not c Is Nothing And c.Address <> StartAddr
        End If
    End If
End Function
 
Upvote 0

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand
Sorry, this was a careless mistake. I've checked everything and think that the code below should work flawlessly.
The changes I made from my first code according to post #6 are shown in red.

Rich (BB code): 
Public Sub CustomSearch()

    Dim Sht As Worksheet
    Set Sht = ThisWorkbook.Worksheets("RÉSUMÉ")     ' <<< change sheet name to suit
      
    With Sht
        Dim Rng As Range
        Set Rng = .Range("G3:G" & .Cells(.Rows.Count, "G").End(xlUp).Row)
        Dim arr As Variant
        arr = .Range("A1:H1").Value
    End With
    
    Application.ScreenUpdating = False
    Rng.EntireRow.Hidden = False
    
    Dim i As Long
    For i = 2 To UBound(arr, 2) Step 2
        Dim c As Range, Result As Range
        Set c = FindSomeText(arr(1, i), Rng)
        If Not c Is Nothing Then
            If Result Is Nothing Then
                Set Result = c
            Else
                Set Result = Application.Union(Result, c)
            End If
        End If
    Next i
    If Not Result Is Nothing Then
        Rng.EntireRow.Hidden = True
        Result.EntireRow.Hidden = False
    End If
    Application.ScreenUpdating = True
End Sub

Public Function FindSomeText(ByVal argText As String, ByVal argRng As Range) As Range
    Dim c As Range, StartAddr As String
    If Len(argText) > 0 Then
        Set c = argRng.Find(argText, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False, SearchOrder:=xlByColumns)
        If Not c Is Nothing Then
            StartAddr = c.Address
            Do
                If FindSomeText Is Nothing Then
                    Set FindSomeText = c
                Else
                    Set FindSomeText = Application.Union(FindSomeText, c)
                End If
                Set c = argRng.FindNext(c)
            Loop While Not c Is Nothing And c.Address <> StartAddr
        End If
    End If
End Function
 
Upvote 0
GWteB said:
Sorry, this was a careless mistake. I've checked everything and think that the code below should work flawlessly.
The changes I made from my first code according to post #6 are shown in red.

Rich (BB code): 
Public Sub CustomSearch()

    Dim Sht As Worksheet
    Set Sht = ThisWorkbook.Worksheets("RÉSUMÉ")     ' <<< change sheet name to suit
     
    With Sht
        Dim Rng As Range
        Set Rng = .Range("G3:G" & .Cells(.Rows.Count, "G").End(xlUp).Row)
        Dim arr As Variant
        arr = .Range("A1:H1").Value
    End With
   
    Application.ScreenUpdating = False
    Rng.EntireRow.Hidden = False
   
    Dim i As Long
    For i = 2 To UBound(arr, 2) Step 2
        Dim c As Range, Result As Range
        Set c = FindSomeText(arr(1, i), Rng)
        If Not c Is Nothing Then
            If Result Is Nothing Then
                Set Result = c
            Else
                Set Result = Application.Union(Result, c)
            End If
        End If
    Next i
    If Not Result Is Nothing Then
        Rng.EntireRow.Hidden = True
        Result.EntireRow.Hidden = False
    End If
    Application.ScreenUpdating = True
End Sub

Public Function FindSomeText(ByVal argText As String, ByVal argRng As Range) As Range
    Dim c As Range, StartAddr As String
    If Len(argText) > 0 Then
        Set c = argRng.Find(argText, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False, SearchOrder:=xlByColumns)
        If Not c Is Nothing Then
            StartAddr = c.Address
            Do
                If FindSomeText Is Nothing Then
                    Set FindSomeText = c
                Else
                    Set FindSomeText = Application.Union(FindSomeText, c)
                End If
                Set c = argRng.FindNext(c)
            Loop While Not c Is Nothing And c.Address <> StartAddr
        End If
    End If
End Function
Click to expand...

Hi! sorry that i took a long time to respond. Idk what is happening but when i put multiple criteria on the "#1, #2, #3, #4" tabs, when i click "search" it shows rows that have ONE of the multiple criteria that i put. What i actually want is that when i click search it only shows me when the rows with tags that have ALL the criteria, and hide all the other rows.
If you would show me how to do that that would be so nice!
Thanks a lot in advance :) i'm slowly beggining to understand this VBA thing haha.
 
Upvote 0
Fredoub20 said:
What i actually want is that when i click search it only shows me when the rows with tags that have ALL the criteria, and hide all the other rows.
Click to expand...

I see. The code below is most likely to do want you want ...
VBA Code: 
Public Sub CustomSearch()

    Dim Sht As Worksheet
    Set Sht = ThisWorkbook.Worksheets("RÉSUMÉ")     ' <<< change sheet name to suit

    With Sht
        Dim Rng As Range
        Set Rng = .Range("G3:G" & .Cells(.Rows.Count, "G").End(xlUp).Row)
        Dim sFOR As String
        sFOR = "*" & .Range("B1").Value & _
               "*" & .Range("D1").Value & _
               "*" & .Range("F1").Value & _
               "*" & .Range("H1").Value & "*"
        Dim arrIN As Variant
        arrIN = Rng.Value
    End With

    Application.ScreenUpdating = False
    Rng.EntireRow.Hidden = False
    
    Dim i As Long
    For i = 1 To UBound(arrIN)
        If arrIN(i, 1) Like sFOR Then
            Dim Result As Range
            If Result Is Nothing Then
                Set Result = Rng.Cells(i, 1)
            Else
                Set Result = Application.Union(Result, Rng.Cells(i, 1))
            End If
        End If
    Next i
    If Not Result Is Nothing Then
        Rng.EntireRow.Hidden = True
        Result.EntireRow.Hidden = False
    End If
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
It's working! can you make it so the order of the criteria doesn't matter? If i try to put 2 criteria and switching them it doesn't show me the same result :/
 
Upvote 0
I could have taken that into account ... but I didn't :cry: Will post an update shortly :cool:
 
Upvote 0
Updated attempt ...

VBA Code: 
Public Sub CustomSearch()

    Dim Sht As Worksheet
    Set Sht = ThisWorkbook.Worksheets("RÉSUMÉ")     ' <<< change sheet name to suit
    
    Application.ScreenUpdating = False
    With Sht
        .Cells.EntireRow.Hidden = False
        Dim Rng As Range
        Set Rng = .Range("G3:G" & .Cells(.Rows.Count, "G").End(xlUp).Row)
        Dim arrIN As Variant
        arrIN = Rng.Value
        Dim arrFOR(1 To 4) As String
        arrFOR(1) = .Range("B1").Value
        arrFOR(2) = .Range("D1").Value
        arrFOR(3) = .Range("F1").Value
        arrFOR(4) = .Range("H1").Value
    End With
    Dim i As Long
    For i = 1 To UBound(arrIN)
        If CBool(InStr(1, arrIN(i, 1), arrFOR(1), vbTextCompare)) And CBool(InStr(1, arrIN(i, 1), arrFOR(2), vbTextCompare)) And _
           CBool(InStr(1, arrIN(i, 1), arrFOR(3), vbTextCompare)) And CBool(InStr(1, arrIN(i, 1), arrFOR(4), vbTextCompare)) Then
            Dim Result As Range
            If Result Is Nothing Then
                Set Result = Rng.Cells(i, 1)
            Else
                Set Result = Application.Union(Result, Rng.Cells(i, 1))
            End If
        End If
    Next i
    If Not Result Is Nothing Then
        Rng.EntireRow.Hidden = True
        Result.EntireRow.Hidden = False
    End If
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
GWteB said:
Updated attempt ...

VBA Code: 
Public Sub CustomSearch()

    Dim Sht As Worksheet
    Set Sht = ThisWorkbook.Worksheets("RÉSUMÉ")     ' <<< change sheet name to suit
   
    Application.ScreenUpdating = False
    With Sht
        .Cells.EntireRow.Hidden = False
        Dim Rng As Range
        Set Rng = .Range("G3:G" & .Cells(.Rows.Count, "G").End(xlUp).Row)
        Dim arrIN As Variant
        arrIN = Rng.Value
        Dim arrFOR(1 To 4) As String
        arrFOR(1) = .Range("B1").Value
        arrFOR(2) = .Range("D1").Value
        arrFOR(3) = .Range("F1").Value
        arrFOR(4) = .Range("H1").Value
    End With
    Dim i As Long
    For i = 1 To UBound(arrIN)
        If CBool(InStr(1, arrIN(i, 1), arrFOR(1), vbTextCompare)) And CBool(InStr(1, arrIN(i, 1), arrFOR(2), vbTextCompare)) And _
           CBool(InStr(1, arrIN(i, 1), arrFOR(3), vbTextCompare)) And CBool(InStr(1, arrIN(i, 1), arrFOR(4), vbTextCompare)) Then
            Dim Result As Range
            If Result Is Nothing Then
                Set Result = Rng.Cells(i, 1)
            Else
                Set Result = Application.Union(Result, Rng.Cells(i, 1))
            End If
        End If
    Next i
    If Not Result Is Nothing Then
        Rng.EntireRow.Hidden = True
        Result.EntireRow.Hidden = False
    End If
    Application.ScreenUpdating = True
End Sub
Click to expand...
Thank you so much, it works like a champ! you're the best :)
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question Question
Prompt To Allow User To Edit VBA
Replies
4
Views
359
Joe4
Joe4
D
  • Question Question
VBA help to create button that moves to next row after taking screenshot
Replies
1
Views
335
ranman256
ranman256
youbitto
  • Solved
Index match VBA taking too long
2 3
Replies
27
Views
556
Alex Blakenburg
A
T
  • Question Question
Optimising my VBA to improve the efficiency of my Workbook
2 3
Replies
21
Views
2K
Tmini
T
Eawyne
  • Question Question
[VBA] Resize a screenshot on specific coordinates
Replies
2
Views
435
Eawyne
Eawyne

Forum statistics

Threads
1,223,886
Messages
6,175,193
Members
452,616
Latest member
intern444

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top