in deel van bestandsnaam zoeken

[kibus]

goedemorgen

is het mogelijk om in een map te zoeken op een deel van een bestandsnaam (bevat) en deze weer te geven in excel

alvast bedankt

Edwin

 

[ExcelAmateur]

Kibus,

Dit bestandje had ik nog bewaard, kijk of je er iet mee kunt.
Je zoekt via een Userform.

Je kan in voeren wat je wil en hij geeft als het er is de volledige naam

 

[kibus]

goedemorgen

Hartelijk dank

ik vond dit ook alleen mijn inputbox gaat niet goed.. iemand enig idee?


Sub ListFiles()

dim ev as string

ev = "*" & InputBox("geef receptnaam/artikelcode") & "*"

F = Dir("T:\recept\ev")
Do While Len(F) > 0
ActiveCell.Formula = F
ActiveCell.Offset(1, 0).Select
F = Dir()
Loop
End Sub

 

[Warme bakkertje]

Pad in A1 (bv. G:\mijn documenten) en zoekwaarde in E1

Sub tst()
    With CreateObject("Scripting.FileSystemObject").GetFolder(Range("A1"))
        For Each objFile In .Files
            If InStr(objFile.Name, Range("E1")) > 0 Then FoundFile = FoundFile & "|" & objFile.Name: x = x + 1
            
        Next objFile
    End With
    Cells(14, 1).Resize(x) = Application.Transpose(Split(Mid(FoundFile, 2), "|"))
End Sub

 

[snb]

Sub M_snb()
    With Application.FileDialog(3)
        .AllowMultiSelect = True
       .InitialFileName = "*woord*"
       .Show
       For j = 1 To .SelectedItems.Count
         Cells(j, 6) = .SelectedItems(j)
       Next
    End With
End Sub

 

[kibus]

dank voor jullie reactie

de code werkt nog niet helemaal zie ik wat over het hoofd ,

edwin

 

[kibus]

het is wel wat omslachtig, maar graag hulp zou toch in 1 keer kunnen ipv extra filteren 4000 recepten eerst moeten laden

Sub ingeven()
Dim ev As String
ev = InputBox("geef recept naam in")
Range("a1") = ev
Application.ScreenUpdating = False

Sheets("lijst").Visible = True
Sheets("resultaat").Visible = True

Call Laden
End Sub

Sub Laden()

Sheets("lijst").Select
Range("a2").Select
         F = Dir("P:\Dokumenten Algemeen\Produkt_Recept programma\Recepten\*.*")
         Do While Len(F) > 0
         ActiveCell.Formula = F
         ActiveCell.Offset(1, 0).Select
         F = Dir()
        Loop
            
    ActiveCell.Offset(-1, 1) = "X"
    Range("B2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.FillDown

Range("a2").CurrentRegion.Select
ActiveWorkbook.Names.Add Name:="tabel", RefersTo:=Selection
Range("h2").CurrentRegion.Select
ActiveWorkbook.Names.Add Name:="crit", RefersTo:=Selection


Range("=tabel").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
Range("=crit"), CopyToRange:=Range("=plakken"), Unique:=False
Sheets("lijst").Visible = False

End Sub


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If ActiveCell = "toon klik hier" Then
Application.ScreenUpdating = False
ActiveCell.Offset(0, -1).Select
Shell "explorer.exe " & "P:\Dokumenten Algemeen\Produkt_Recept programma\Recepten\" & ActiveCell.Text
Else
End If

End Sub

 

[snb]

Je ziet

http://www.helpmij.nl/forum/showthr...snaam-zoeken?p=5382291&viewfull=1#post5382291

over het hoofd.

 

[kibus]

goedendag snb

uw manier zou ook kunnen idd, maar mbt tot mijn einddoel kom ik nog niet ver hiermee, sorry

de bedoeling is dat de gevonden bestandsnamen uiteindelijk weg worden geschreven in een pdf map .... om dat te doen gebruik ik onderstaande code weer .

Sub wegschrijven()
Range("a1") = Application.UserName

Range("a2").Select

Start:
If ActiveCell = "klaar" Then
Exit Sub
Else
If ActiveCell = "x" Then
Dim oWord As Object
Dim oDoc As Object
Dim eV As String
eV = Range("B1").Value
Dim evi As String
evi = Range("c1").Value
Set oWord = CreateObject("Word.Application")
Set oDoc = oWord.Documents.Open(eV)
oDoc.ExportAsFixedFormat OutputFileName:=evi, ExportFormat:=wdExportFormatPDF
oWord.Quit
' oWord.Visible = True
ActiveCell = " in map"
ActiveCell.Offset(1, 0).Select
GoTo Start
Else
ActiveCell.Offset(1, 0).Select
GoTo Start
End If

End If


End Sub

 

[snb]

Dan bevatte de beginvraag wel erg partiële informatie.

Ik ben 'benieuwd' wat de vervolgvraag zal zijn.

 

[Warme bakkertje]

Sub tst()
    With CreateObject("Scripting.FileSystemObject").GetFolder(Range("A1"))
        For Each objFile In .Files
            If InStr(UCase(objFile.Name), UCase(Range("E1"))) > 0 Then FoundFile = FoundFile & "|" & objFile.Name: x = x + 1
        Next objFile
    End With
    If FoundFile = vbNullString Then MsgBox "Geen overeenkomsten gevonden": Exit Sub
    Cells(14, 1).Resize(x) = Application.Transpose(Split(Mid(FoundFile, 2), "|"))
End Sub

 

[kibus]

Hartelijk dank, warme bakker het werkt super!