Eigenwijze zoekfunctie (VBA)

[Wexx]

Beste mede excellers,

ik ben al een tijdje bezig om een goedwerkende zoekfunctie te creeren die in mijn sheet d.m.v autofilter precies hetgene eruit haalt wat ik zoek.

2 dingen vallen mij op:

- Alles dat kleiner is als 2 digits (getallen of cijfers) filtert hij niet.
- (zie bijgevoegd bestand als voorbeeld), bij zoeken op het woord "arco" geeft hij resultaat! Maar op plaats 15 (trekveer) staat het woord arco en 2 kolommen verder blabla, deze filtert hij dan weer niet?

Mijn code tot zo ver:

Private Sub CommandButton1_Click()

 With ActiveSheet
        
        .AutoFilterMode = False
        .Range("A6").AutoFilter

        With .AutoFilter.Range

Dim iKol As Integer
If TextBox1.Value <> "" Then
    For iKol = 1 To Range("IV6").End(xlToLeft).Column
        With Worksheets("Blad1").Range(Cells(6, iKol), Cells(65536, iKol))
            Set zk = .Find(TextBox1.Value, LookIn:=xlValues, lookat:=xlPart)
            If Not zk Is Nothing Then
                ActiveSheet.AutoFilter.Range.AutoFilter Field:=iKol, Criteria1:="*" & TextBox1.Value & "*"
            End If
        End With
    Next
End If
 End With
  End With
    End Sub

Bijgevoegd een voorbeeldbestand.

Iemand een hint?
Alvast bedankt voor de reacties.

 

[cow18]

je moet altijd de filter terug vrij geven

Private Sub CommandButton1_Click()
  Dim rBereik  As Range
  With ActiveSheet
    Columns("L").ClearContents                             'alle selecties ongedaan maken
    Set rBereik = Intersect(Columns("A"), Range("A6").CurrentRegion).Offset(0, 11)
    .AutoFilterMode = False
    .Range("A6").AutoFilter
    With .AutoFilter.Range

      Dim iKol As Integer
      If TextBox1.Value <> "" Then
        For iKol = 1 To Range("IV6").End(xlToLeft).Column - 1
          With Worksheets("Blad1").Range(Cells(6, iKol), Cells(65536, iKol))
            Set zk = .Find(TextBox1.Value, LookIn:=xlValues, lookat:=xlPart)
            If Not zk Is Nothing Then
              ActiveSheet.AutoFilter.Range.AutoFilter Field:=iKol, Criteria1:="*" & TextBox1.Value & "*"
              rBereik.SpecialCells(xlVisible).Value = 1    'in alle gefilterde rijen in de L-kolom een 1 zetten
              ActiveSheet.AutoFilter.Range.AutoFilter Field:=iKol  'huidige filter ongedaan maken
            End If
          End With
        Next
      End If
    End With

    .AutoFilterMode = False
    Range("L6").Value = 1
    With rBereik
      .AutoFilter
      .AutoFilter Field:=1, Criteria1:="1"                 'op alle 1-tjes filteren in de L-kolom
    End With
  End With
End Sub

 

[Wexx]

Ha cow18,

bedankt voor je snelle reactie.
Je oplossing lijkt prima te functioneren :thumb:

Ik ben best een tijd bezig geweest om codes bij elkaar te sprokkelen en de functie te creeren die ik graag wilde hebben. Het werkt bijna perfect!
Ik vraag me alleen af waarom als je b.v. het cijfer 15 in de zoekfunctie plaats hij wel met 15A, 15B, 15C en 15D komt maar niet met 15 zelf?

Maar nogmaals vele dank !

 

[Wigi]

Ik vraag me alleen af waarom als je b.v. het cijfer 15 in de zoekfunctie plaats hij wel met 15A, 15B, 15C en 15D komt maar niet met 15 zelf?

De * vooraan en achteraan maken er tekst van. Het getal 15 zal je daarom niet vinden. Dit zou wel kunnen met

ActiveSheet.AutoFilter.Range.AutoFilter Field:=iKol, Criteria1:=TextBox1.Value '"*" & TextBox1.Value & "*"

 

[Wigi]

Een stuk makkelijker is de code van Chip Pearson die zoekt naar iets in een heel bereik. Toegepast op jouw bestand:

Sub CommandButton1_Click()

    Dim SearchRange As Range
    Dim FindWhat As Variant
    Dim FoundCells As Range

    Set SearchRange = Range("A6").CurrentRegion
    FindWhat = TextBox1.Text
    
    Set FoundCells = FindAll(SearchRange:=SearchRange, _
                             FindWhat:=FindWhat, _
                             LookIn:=xlValues, _
                             LookAt:=xlPart, _
                             SearchOrder:=xlByColumns, _
                             MatchCase:=False)
    
    If Not FoundCells Is Nothing Then
        SearchRange.Offset(2).Resize(SearchRange.Rows.Count - 2).EntireRow.Hidden = True
        FoundCells.EntireRow.Hidden = False
    End If

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modFindAll
' By Chip Peasron, chip@cpearson.com. www.cpearson.com
' 24-October-2007
' This module is described at www.cpearson.com/Excel/FindAll.aspx
' Requires Excel 2000 or later.
'
' This module contains two functions, FindAll and FindAllOnWorksheets that are use
' to find values on a worksheet or multiple worksheets.
'
' FindAll searches a range and returns a range containing the cells in which the
'   searched for text was found. If the string was not found, it returns Nothing.

' FindAllOnWorksheets searches the same range on one or more workshets. It return
'   an array of ranges, each of which is the range on that worksheet in which the
'   value was found. If the value was not found on a worksheet, that worksheet's
'   element in the returned array will be Nothing.
'
' In both functions, the parameters that control the search have the same meaning
' and effect as they do in the Range.Find method.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Function FindAll(SearchRange As Range, _
                 FindWhat As Variant, _
                 Optional LookIn As XlFindLookIn = xlValues, _
                 Optional LookAt As XlLookAt = xlWhole, _
                 Optional SearchOrder As XlSearchOrder = xlByRows, _
                 Optional MatchCase As Boolean = False) As Range
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FindAll
' This searches the range specified by SearchRange and returns a Range object
' that contains all the cells in which FindWhat was found. The search parameters to
' this function have the same meaning and effect as they do with the
' Range.Find method. If the value was not found, the function return Nothing.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim FoundCell As Range
    Dim FirstFound As Range
    Dim LastCell As Range
    Dim ResultRange As Range

    With SearchRange
        Set LastCell = .Cells(.Cells.Count)
    End With
    'On Error Resume Next
    On Error GoTo 0
    Set FoundCell = SearchRange.Find(what:=FindWhat, _
                                     after:=LastCell, _
                                     LookIn:=LookIn, _
                                     LookAt:=LookAt, _
                                     SearchOrder:=SearchOrder, _
                                     MatchCase:=MatchCase)

    If Not FoundCell Is Nothing Then
        Set FirstFound = FoundCell
        Set ResultRange = FoundCell
        Set FoundCell = SearchRange.FindNext(after:=FoundCell)
        Do Until False    ' Loop forever. We'll "Exit Do" when necessary.
            If (FoundCell Is Nothing) Then
                Exit Do
            End If
            If (FoundCell.Address = FirstFound.Address) Then
                Exit Do
            End If
            Set ResultRange = Application.Union(ResultRange, FoundCell)
            Set FoundCell = SearchRange.FindNext(after:=FoundCell)
        Loop
    End If

    Set FindAll = ResultRange

End Function

 

[Wexx]

Ha Wigi,

ik ben nu al een tijdje aan het spelen geweest om alles te testen! Ik ben zeer blij met het resultaat.

Mijn dank is dan ook groot voor deze bijdrage. :thumb: