@ Veerj,
Mogelijk ben ik nog niet goed wakker, maar veronderstelt jouw methode niet dat alle files in dezelfde map staan? Ik dacht dat het Montagnard's bedoeling was dat hij eender wanneer te kiezen mappen zou kunnen toevoegen.
@ Arnold,
Zoals ik in een vorig bericht aangaf zou je jezelf veel leed kunnen besparen door het ganse pad in je basislijst op te nemen. Om te importeren zijn er voldoende methodes te verzinnen, maar eerst graag je mening over toevoeging van het pad (voor mezelf zou ik die lijst gewoon op een ander blad zetten)
Voor ongeveer alles is wel een oplossing te verzinnen. Ook zonder het pad krijgen we je laatste ergernis weg. Bij wijze van voorbeeld hierbij een licht uitgebreide code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$2" Then
Application.EnableEvents = False
Range("b4:d18").ClearContents
If Target <> "" Then
tezoekentitel = Cells(2, 2)
Range("b4:d18").ClearContents
nummers = Filter(Application.Transpose(Range("a21:a" & Cells(Rows.Count, 1).End(xlUp).Row)), tezoekentitel, True, vbTextCompare)
Select Case UBound(nummers)
Case -1
MsgBox "er zijn geen titels met deze tekst", vbInformation, "Belangrijke info"
Range("b4:d18").ClearContents: Range("B2").ClearContents
Case Is > 14
MsgBox "er zijn " & UBound(nummers) & " titels met dezelfde tekst gevonden" + (Chr(13)) + (Chr(13)) + " verfijn Uw zoekopdracht", vbInformation, "Belangrijke info"
Range("b4:d18").ClearContents: Range("B2").ClearContents
Case Else
ReDim rijnummer(0 To UBound(nummers))
ReDim hlink(0 To UBound(nummers))
teller = 0
For I = 21 To Cells(Rows.Count, 1).End(xlUp).Row
If UBound(Filter(nummers, Cells(I, 1), True, vbTextCompare)) > -1 Then
rijnummer(teller) = I
hlink(teller) = Cells(I, 1).Hyperlinks(1).Address
teller = teller + 1
End If
Next I
Cells(4, 2).Resize(UBound(nummers) + 1) = Application.Transpose(nummers)
Cells(4, 4).Resize(UBound(nummers) + 1) = Application.Transpose(rijnummer)
For I = 0 To UBound(nummers)
Cells(I + 4, 2).Hyperlinks.Add Anchor:=Cells(I + 4, 2), Address:=hlink(I)
Next I
End Select
End If
Application.EnableEvents = True
End If
Cells(2, 2).Font.Underline = xlUnderlineStyleNone
Range("B4:B18").Font.Underline = xlUnderlineStyleNone
Range("A21").Select
Range("B2").Select
End Sub
Maar, wat ik ook al aangaf, dat staat los van de mogelijkheid dat je meer dan één keer dezelfde map toevoegt (per ongeluk, of omdat je bv. mp3's aan die map hebt toegevoegd), dus dat doen we wel in een volgende fase.