Problemen FileSearch

Status
Niet open voor verdere reacties.
2

2010Peter

Gebruiker
Lid geworden
29 okt 2010
Berichten
15
Voorheen werkte ik altijd met Excel 2003 maar sinds kort met Excel 2010. Filesearch werkt niet meer maar ik weet niet hoe ik onderstaande werkend kan krijgen.

Wie kan mij helpen?

Zoeken:
Dim strnaam, strdocument As String
strdocument = Range("B56").Value
Set fs = Application.FileSearch
With fs
.NewSearch
.LookIn = Range("B57").Value
.Filename = Range("B56").Value
.SearchSubFolders = True
If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) = 1 Then
For I = 1 To .FoundFiles.Count
strnaam = .FoundFiles(I)
Range("B58").Value = strnaam
Next I
Else
MsgBox "Het document " & strdocument & " is niet gevonden."
Range("B58").ClearContents
End If
End With

Peter
 
In 2007 ev moet je of werken met Scripting.FileSystemObject of met de Dir functie, met de Dir functie is het volgens mij wat lastig om in onderliggende mappen te zoeken.

Plaats onderstaande code in een module,
in B57 het pad eindigend met \
in B56 de bestandsnaam zonder de extensie
in de sub Zoeken kun je het bestandstype nog wijzigen (of ook naar een cel laten verwijzen) en kun je middels True/False bij ZoekOnderliggendeMappen aangeven of er wel of niet in onderliggende mappen gezocht moet worden.

Mocht het zo zijn dat er meerdere bestanden op verschillende locaties met dezelfde naam als lijstje vanaf B58 moet worden weergegeven dan moet het Else-stukje nog wat worden aangepast.

Code: 
Private BestandenLijst() As String

Sub Zoeken()
    NieuweFileSearch Pad:=Range("B57").Value, BestandsNaam:=Range("B56").Value, BestandsType:="xls*", _
        ZoekOnderliggendeMappen:=True, Teller:=0
    If Join(BestandenLijst) = Empty Then
        MsgBox "Het document " & Range("B56").Value & " is niet gevonden."
    Else
        Range("B58").Value = BestandenLijst
    End If
End Sub

Private Sub NieuweFileSearch(Pad As String, BestandsNaam As String, BestandsType As String, _
    ZoekOnderliggendeMappen As Boolean, Teller As Long)
    Dim FSO As Object, Map As Object, Bestand As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    For Each Bestand In FSO.GetFolder(Pad).Files
        If Bestand.Name Like BestandsNaam & "." & BestandsType Then
            Teller = Teller + 1
            ReDim Preserve BestandenLijst(1 To Teller)
            BestandenLijst(Teller) = Pad & Bestand.Name
        End If
    Next
    If ZoekOnderliggendeMappen Then
        For Each Map In FSO.GetFolder(Pad).Subfolders
            NieuweFileSearch Pad & Map.Name & "\", BestandsNaam, BestandsType, True, Teller
        Next
    End If
End Sub
 
Als ik de macro uitvoer dan krijg ik de volgende foutmelding:

Compileerfout: Een variabele is niet gedefinieerd.

ReDim Preserve Bestandenlijst(1 To Teller)

Peter
 
Heb je helemaal bovenaan de module dit stukje:
Code: 
Private BestandenLijst() As String
Ook gekopieerd?
 
Nee dus.

Het werkt, geweldig. Dank je wel.

Groet,

Peter
 
Laatst bewerkt:
was ik net een antwoord aan het typen, werkt het dus toch wel :D

mooi, ook weer opgelost ;)
 
Ik heb de code enigszins aangepast aangezien er naar meerdere bestanden moet worden gezocht. Als er naar vijf bestanden moet worden gezocht en hij vind de eerste drie bestanden dan wordt de bestandsnaam en het pad van het gevonden bestand correct weergegeven. Als het vierde en vijfde bestand niet kan worden gevonden dan krijg ik de bestandsnaam en het pad van het derde gevonden bestand. Kan ik de bestandslijst ook iedere keer resetten zodat in bovenstaand voorbeeld er geen bestandsnaam en pad wordt weergegeven bij het vierde en vijfde bestand?

Groet,

Peter
 
Nu zie ik jouw aangepaste code niet, wellicht is het in dit geval handig door niet teveel ingrijpende veranderingen toe te voegen om in de NieuweFileSearch macro net voor de on error resume next:
Code: 
BestandenLijst(1) = "Niet gevonden"
toe te voegen, je zet nu steeds "Niet gevonden" neer tenzij er wel wat wordt gevonden,
dan wordt deze weer overschreven.
 
Hallo Eric,

Als ik de voorgestelde regel toevoeg dan krijg ik de volgende foutmelding:

Fout 9 tijdens uitvoeren. Het subscript valt buiten het bereik.

Hieronder heb ik de gehele macro staan.

Is het ook mogelijk om in plaats van de tekst Niet gevonden in de cel te plaatsen helemaal geen tekst te plaatsen en de cel leeg te houden / maken.

Code: 
Private BestandenLijst() As String
Private counter As Integer

Sub DATA()

Sheets("Cockpit").Select
ActiveSheet.Unprotect
Dim DATADocument As String
DATADocumentnaam = Range("AB43").Value
DATADocumentlocatie = Range("AB44").Value
Documentnaam = Range("AB9").Value
Application.DisplayAlerts = False
Workbooks.Open Filename:="" & DATADocumentlocatie & "", ReadOnly:=True
Columns("A:AA").Select
Selection.Copy
Windows("" & Documentnaam & "").Activate
Sheets("Cockpit").Select
Columns("AA:BA").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("AB9").Value = ActiveWorkbook.Name
Range("AB10").Value = ActiveWorkbook.Path
counter = 0
Application.Run "Bestanden_Zoeken"
Range("AB9").Value = ActiveWorkbook.Name
Range("AB10").Value = ActiveWorkbook.Path
Columns("Z:BA").Select
Selection.EntireColumn.Hidden = True
Windows("" & DATADocumentnaam & "").Close savechanges:=False
Windows("" & Documentnaam & "").Activate
Sheets("Cockpit").Select
Range("A1").Select

End Sub

Sub Bestanden_Zoeken()

If Range(Cells(13 + counter, 27), Cells(13 + counter, 27)).Value <> "" Then
Application.Run "Zoeken2"
Exit Sub
End If

End Sub

Sub Zoeken2()
                                              
NieuweFileSearch Pad:=Range(Cells(14 + counter, 28), Cells(14 + counter, 28)).Value, BestandsNaam:=Range(Cells(13 + counter, 28), Cells(13 + counter, 28)).Value, BestandsType:="xls*", _
ZoekOnderliggendeMappen:=True, Teller:=0
If Join(BestandenLijst) = Empty Then
MsgBox "Het document " & Range(Cells(13 + counter, 28), Cells(13 + counter, 28)).Value & " is niet gevonden."
counter = counter + 3
Application.Run "Bestanden_Zoeken"
Else
Range(Cells(15 + counter, 28), Cells(15 + counter, 28)).Value = BestandenLijst
counter = counter + 3
Application.Run "Bestanden_Zoeken"
Exit Sub
End If
End Sub

Private Sub NieuweFileSearch(Pad As String, BestandsNaam As String, BestandsType As String, _
ZoekOnderliggendeMappen As Boolean, Teller As Long)
Dim FSO As Object, Map As Object, Bestand As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
BestandenLijst(1) = "Niet gevonden"
On Error Resume Next
For Each Bestand In FSO.GetFolder(Pad).Files
If Bestand.Name Like BestandsNaam & "." & BestandsType Then
Teller = Teller + 1
ReDim Preserve BestandenLijst(1 To Teller)
BestandenLijst(Teller) = Pad & Bestand.Name
End If
Next
If ZoekOnderliggendeMappen Then
For Each Map In FSO.GetFolder(Pad).Subfolders
NieuweFileSearch Pad & Map.Name & "\", BestandsNaam, BestandsType, True, Teller
Next
End If

End Sub
Groet,

Peter
 
Laatst bewerkt:
@Peter:
Zou je de code in de Code tag willen opmaken? Je krijgt nu wel erg lange pagina's... En die zijn ook nog eens minder handig te lezen met al die code. Kwestie van topic even bewerken, en de knop met [#] gebruiken
 
Peter,

Allereerst neem het advies/verzoek van Michel ter harte,

Ik heb getracht jouw code wat te ontrafelen / aan te passen, zonder voorbeeld-bestand wordt het wel wat lastig moet ik zeggen....

Probeer onderstaande code eens (in een kopie van jouw bestand), werkt dit nu niet plaats dan svp een voorbeelbestandje incl een bestandje waaruit gekopieerd moet worden.

De NieuweFilesearch heb ik intact gelaten, al deze code dient ter vervanging van jouw geplaatste code

Code: 
Private BestandenLijst() As String

Sub DATA()
    Dim DATADocumentlocatie As String, counter As Long

    counter = 0

    With Application
       .ScreenUpdating = False
       .DisplayAlerts = False
    End With

    With Sheets("Cockpit")
        .Unprotect
        DATADocumentlocatie = .Range("AB44").Value
    End With

    With Workbooks.Open(DATADocumentlocatie, , True)
        Sheets(1).Columns("A:AA").Copy
        ThisWorkbook.Sheets("Cockpit").Columns("AA:BA").PasteSpecial
        Application.CutCopyMode = False
        .Close savechanges:=False
    End With

    With Sheets("Cockpit")
        .Range("AB9").Value = ActiveWorkbook.Name
        .Range("AB10").Value = ActiveWorkbook.Path
        .Columns("Z:BA").EntireColumn.Hidden = True
        Do
            NieuweFileSearch Pad:=.Cells(14 + counter, 28).Value, BestandsNaam:=.Cells(13 + counter, _
                28).Value, BestandsType:="xls*", ZoekOnderliggendeMappen:=True, Teller:=0
            If Join(BestandenLijst) = Empty Then
                MsgBox "Het document " & .Cells(13 + counter, 28).Value & " is niet gevonden."
            Else
                .Cells(15 + counter, 28).Value = BestandenLijst
                BestandenLijst(1) = ""
            End If
            counter = counter + 3
        Loop While Sheets("Cockpit").Cells(13 + counter, 27).Value <> ""
    End With
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

    ThisWorkbook.Sheets("Cockpit").Range("A1").Select

End Sub

Private Sub NieuweFileSearch(Pad As String, BestandsNaam As String, BestandsType As String, _
    ZoekOnderliggendeMappen As Boolean, Teller As Long)
    Dim FSO As Object, Map As Object, Bestand As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
  
    On Error Resume Next
    For Each Bestand In FSO.GetFolder(Pad).Files
        If Bestand.Name Like BestandsNaam & "." & BestandsType Then
            Teller = Teller + 1
            ReDim Preserve BestandenLijst(1 To Teller)
            BestandenLijst(Teller) = Pad & Bestand.Name
        End If
    Next
    If ZoekOnderliggendeMappen Then
        For Each Map In FSO.GetFolder(Pad).Subfolders
            NieuweFileSearch Pad & Map.Name & "\", BestandsNaam, BestandsType, True, Teller
        Next
    End If

End Sub
 
Laatst bewerkt:
Michel, bedankt voor de tip c.q. het advies. Ik zal de code voortaan anders opmaken.

Eric, het werkt perfect. Daarnaast is het mooi om te zien dat jij compactere code gebruikt voor hetzelfde resultaat. Zo leer je iedere dag weer. Wederom bedankt.

Groet,

Peter
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan