zoekroutine aanpassen

Herhaalde oproep voor programmeurs.
Wie gaat de uitdaging aan?

Hoe kan ik deze zoekroutine aanpassen, zodat ik ook een gedeelte van de naam van het te zoeken softwarepakket kan invoeren en hij niet hoofdletterafhankelijk is?

Ik stuur een gestripte versie van het bestand mee.

Sub zoeken()
Dim zoekprg, gevonden As String
Dim i As Integer
zoekprg = InputBox("Welk programma zoekt u?", "Zoeken")
For i = 1 To Sheets.Count
Sheets(i).Select
Range("A3").Select
While ActiveCell.Value <> ""
If ActiveCell.Value = zoekprg Then
If gevonden = "" Then
gevonden = gevonden & ActiveSheet.Name
Else
gevonden = gevonden & ", " & ActiveSheet.Name
End If
End If
ActiveCell.Offset(1, 0).Select
Wend
Next i
MsgBox ("De applicatie " & zoekprg & " is gevonden op sheet: " & gevonden)
End Sub

De volgende code bovenaan de module te plaatsen:

Option Compare Text

Maar ben niet zeker, niet getest?

Pierre

Geweldig Pierre!
Het maakt nu niet meer uit of ik HOOFD- of kleine letters invoer.
Nu alleen nog een gedeelte van de zoekstring: bv. bos in plaats van Bosatlas Europa.

Dat met de tabbladen ga ik bestuderen. Het blad INFO kan ik helaas niet vinden .

Herhaalde oproep voor programmeurs!
Wie gaat de uitdaging aan?

Wie?

Wie, o wie lost dit voor mij op?

Hoi Hans,

Het antwoord op je vraag:

Sub zoeken()
Dim zoekprg, gevonden As String
Dim i As Integer
zoekprg = InputBox("Welk programma zoekt u?", "Zoeken")
For i = 1 To Sheets.Count
Sheets(i).Select
Range("A3").Select
While ActiveCell.Value <> ""
If ActiveCell.Value Like "*" & zoekprg & "*" Then
If gevonden = "" Then
gevonden = gevonden & ActiveSheet.Name
Else
gevonden = gevonden & ", " & ActiveSheet.Name
End If
End If
ActiveCell.Offset(1, 0).Select
Wend
Next i
MsgBox ("De applicatie " & zoekprg & " is gevonden op sheet: " & gevonden)
End Sub

Maar je doet er beter aan een andere macro te gebruiken. Sneller... korter... en beter:

Sub Zoeken2()
Dim zoekprg As String
Dim gevonden As String
Dim i As Integer
Dim rng As Range
zoekprg = InputBox("Welk programma zoekt u?", "Zoeken")
For i = 1 To Sheets.Count
Set rng = Sheets(i).Range("A3:A1000").Find(what:="*" & zoekprg & "*")
If Not rng Is Nothing Then
gevonden = gevonden & vbCrLf & Sheets(i).Name
End If
Next
MsgBox "De applicatie " & zoekprg & " is gevonden op sheet: " & gevonden
End Sub

Luc

Hallo Luc,

Bedankt dat je de moeite hebt genomen om dit uit te volgelen voor mij.
Kan nu helaas niet (moet weg), maar ga er morgen mee aan de slag.
Je hoort nog van mij.

Hallo Luc,

Jouw zoekroutine werkt perfect en snel!
Nog één vraagje:
Kun je hem nog zo aanpassen, dat wanneer er niets gevonden wordt, hij bv. de melding geeft:
De applicatie Dreamweaver komt niet voor in de sheets! ?

Hoi Hans,

zo dus:

Sub Zoeken2()
Dim zoekprg As String
Dim gevonden As String
Dim i As Integer
Dim rng As Range
zoekprg = InputBox("Welk programma zoekt u?", "Zoeken")
For i = 1 To Sheets.Count
Set rng = Sheets(i).Range("A3:A1000").Find(what:="*" & zoekprg & "*")
If Not rng Is Nothing Then
gevonden = gevonden & vbCrLf & Sheets(i).Name
End If
Next

If Len(gevonden)>0 Then
MsgBox "De applicatie " & zoekprg & " is gevonden op sheet: " & gevonden
Else
MsgBox "De applicatie " & zoekprg & " komt niet voor in de Sheets"
End If
End Sub

Luc

Hallo Luc,

Fantastisch!
De zoekroutine loopt perfect: bedankt!
Deze vraag heeft zo lang op het forum gestaan en jij lost dat zo maar even op.
Fijne feestdagen en een gezond 2005.

Hallo Luc,

De zoekroutine heeft nog een klein schoonheidsfoutje:
Wanneer bij het zoeken niets wordt ingevuld, geeft hij als resultaat:
Scholen
6
Zoek
Dit zijn de namen van de tabbladen.
Kun je de routine zo aanpassen dat hij dat weglaat en aangeeft: Er is niets gevonden of zoiets?

Sub Zoeken()
Dim zoekprg As String
Dim gevonden As String
Dim i As Integer
Dim rng As Range
zoekprg = InputBox("Welk programma zoekt u?", "Zoeken")
If zoekprg ="" Then
MsgBox "U moet iets invullen"
Exit Sub
For i = 1 To Sheets.Count
Set rng = Sheets(i).Range("A3:A1000").Find(what:="*" & zoekprg & "*")
If Not rng Is Nothing Then
gevonden = gevonden & vbCrLf & Sheets(i).Name
End If
Next

If Len(gevonden) > 0 Then
MsgBox "De applicatie " & zoekprg & " is gevonden op sheet: " & gevonden
Else
MsgBox "De applicatie " & zoekprg & " komt niet voor in de Sheets"
End If
End Sub

Luc

Hallo Luc,

Wel een heel snelle reactie, maar ik krijg nu bij het zoeken de melding:
Compileerfout: Blok If zonder End If

Juist... komt omdat ik hier code zit te schrijven zonder testen. Was inderdaad End If vergeten

Sub Zoeken()
Dim zoekprg As String
Dim gevonden As String
Dim i As Integer
Dim rng As Range
zoekprg = InputBox("Welk programma zoekt u?", "Zoeken")
If zoekprg ="" Then
MsgBox "U moet iets invullen"
Exit Sub
End If
For i = 1 To Sheets.Count
Set rng = Sheets(i).Range("A3:A1000").Find(what:="*" & zoekprg & "*")
If Not rng Is Nothing Then
gevonden = gevonden & vbCrLf & Sheets(i).Name
End If
Next

If Len(gevonden) > 0 Then
MsgBox "De applicatie " & zoekprg & " is gevonden op sheet: " & gevonden
Else
MsgBox "De applicatie " & zoekprg & " komt niet voor in de Sheets"
End If
End Sub

Luc

Hallo Luc,

Nu werkt het perfect.
Heel erg bedankt voor je moeite en wie weet tot een andere keer.

Sorrty Luc: een laatsdte vraag.
Is het mogelijk het antwoord er bv. zo uit te laten zien?
De applicatie WoordenTotaal is gevonden op sheet......
Dus de naam van de applicatie Vet drukken .

Dat kan niet met een gewone msgbox.

Daarvoor zal je zelf een UserForm moeten maken. En dan vraag ik me af of het die moeite wel waard is?

Luc

OK.
In ieder geval bedankt voor je reactie.
Prettige feestdagen.