Tak to je pecka, nečekal jsem to takhle rychle. Moc děkuji. Jen tedy nešla by tam vložit podmínka, která by ignorovala slovo "Název položky"? Jelikož to načte i názvy všech nadpisů ve sloupci B když zadám třeba začátek slova "na" a chci vyhledávát nástěnky.
Najdi v kódu to mezi if a pak nahraď/uprav na toto
If Not c.Value = "Název položky" Then
lb.AddItem c.Value
lb.Column(lb.ColumnCount - 1, lb.ListCount - 1) = c.Offset(0, 1).Value
lb.Column(lb.ColumnCount - 2, lb.ListCount - 1) = c.Offset(0, 4).Value
End If
První část kódu
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Dim strWhat As String, lb As MSForms.ListBox
- slovo co se bude hledat
strWhat = TextBox1.Text
Set lb = ListBox1
- list na kterém se bude hledat
Dim arrLists, l
arrLists = Array("Položky")
-počet sloupcu co se zobrazí v LB
lb.Clear
lb.ColumnCount = 3
For l = LBound(arrLists) To UBound(arrLists)
-zavolani fce s parametry
FindTextStartedWith strWhat, arrLists(l), lb
Next
End Sub
fce.
Sub FindTextStartedWith(ByVal WhatText As String, ByVal ListWhere As Variant, lb As MSForms.ListBox)
Dim r As Range, c As Range, firstAddress
-hvězdičky jako zástupný znak
'pridano aby hledalo vse co obsahuje
WhatText = "*" & WhatText & "*"
-hledat ve sloupci B na listě co se zadl výše
With Worksheets(ListWhere).Columns("B")
Set c = .Find(WhatText, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
- nalezené shody přidej do pole
If Not c Is Nothing Then
firstAddress = c.Address
Do
If UCase(c.Value) Like UCase(WhatText) & "*" Then
If r Is Nothing Then
Set r = c
Else
Set r = Application.Union(r, c)
End If
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
If Not r Is Nothing Then
For Each c In r
-přidávání shod do seznamu LB
If Not c.Value = "Název položky" Then
lb.AddItem c.Value
lb.Column(lb.ColumnCount - 1, lb.ListCount - 1) = c.Offset(0, 1).Value
lb.Column(lb.ColumnCount - 2, lb.ListCount - 1) = c.Offset(0, 4).Value
End If
Next
End If
End Sub
Jojo, to mě taky napadlo, ale tohle byl jen zkušební soubor a v té ostré verzi co mám (cca 20 Mb, tak jsem sem dal jen tu část, kde chci upravovat), jsou na tento list a hlavně na tyto řádky formuláře navázány vzorce do dalších formulářů (faktura aj.) takže by mě to dělalo všude hapr. Je to složité tam vložit start a konec zápisu?
Ještě taková drobnost při vkládání do nabídky. Příkaz End na konci kódu zavře UF, pokud příkaz vymažu, je to ok, ale stále dokola se mě po vložení do formuláře zobrazuje MsgBox s upozorněním. Nešlo by to nějak ošetřit, aby se otevřel jen jednou pokud je UF Stále zobrazen a opakovaně vkládám položky z jednoho a toho samého výsledku vyhledaných položek?
16203_vyhledani-polozky.rar (191kB, staženo 25x)
RSS nejnovější články