VBA som finder alle filer i mapper og undermapper

Ja det er muligt
Vender tilbage ...

Indsættes i Excel-fil

Const filNavn = "Fil1.xlsx"                'JUSTERES
Const startMappe = "D:\MinMappe"            'JUSTERES
Sub søgEfterFil()
    traverserDrev startMappe
End Sub
Private Sub traverserDrev(mappenavn)
    Dim fs, f, f1, fc
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(mappenavn)
    Set fc = f.SubFolders
   
    For Each f1 In fc
        findFiler f1.Path
        traverserDrev f1
    Next
End Sub
Private Sub findFiler(mappesti)
Dim fs, f, f1, fc, fNavn As String, svar As Integer

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(mappesti)
    Set fc = f.Files
   
    For Each f1 In fc
Rem hvis søgte navn - spørg om justeres
        If LCase(f1.Name) = LCase(filNavn) Then
            svar = MsgBox("Skal fil justeres?", vbYesNo, mappesti & "\" & f1.Name)
            If svar = 6 Then
                Workbooks.Open mappesti & "\" & filNavn
                ActiveWorkbook.Sheets("Relevans").Activate
                ActiveSheet.Range("E10") = ""
                ActiveSheet.Range("E11") = "JA"
                ActiveWorkbook.Save
            End If
        End If
    Next
End Sub

Ja, for pokker.
Den gør lige det jeg tænkte og så slipper jeg for at sidde og lede efter de enkelte filer.
Mange for hjælpen :-)

Nu har jeg siddet og kørt nogle filer igennem og det virker super.
Kunne man udvide koden med at den i "kildefilen" noterer de filer den har rettet.

Jeg tænker at den i arket "ListeMedFiler" indsætter filnavnene i celle A1, A2, A3 osv.
Det vil være super at have dette til overblikket når man har rendt filerne igennem.

Selv tak

Kildelfilen er altså filen med VBA koden
Arket du nævner kunne vel være Ark1 - omdøbt
Går ud fra at hele stien skal med
Det skulle ikke være noget problem.

Der skal vel tages højde for flere kørsler eller ?
Så der ikke overskrives i arket ListeMedFiler

Jeps kildefilen er den med koden.
Jeps det kunne være ark1 som er omdøbt
Jeps hele stien skulle gerne med incl. filnavnet.
Den må meget gerne tage højde for flere kørsler, så den "bygger videre" på listen.

Ok - fortsætter på VBA-koden iflg. #6 - vel nok i morgen

Super :-)

Rem Version 2
Rem =========
Const filNavn = "Fil1.xlsx"                'JUSTERES
Const startMappe = "D:\MinMappe"            'JUSTERES
Const arkListeMedFiler = "ListeMedFiler"    'Kan justeres

Dim system As Object, antalRækker As Integer                  '1. ledige række på arket "ListeMedFiler"
Sub søgEfterFil()
    Set system = ActiveWorkbook
    antalRækker = findFørsteRække + 1
    traverserDrev startMappe
End Sub
Private Function findFørsteRække()
    With system.Sheets(arkListeMedFiler)
        findFørsteRække = ActiveCell.SpecialCells(xlLastCell).Row
    End With
End Function
Private Sub traverserDrev(mappenavn)
    Dim fs, f, f1, fc
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(mappenavn)
    Set fc = f.SubFolders
   
    For Each f1 In fc
        findFiler f1.Path
        traverserDrev f1
    Next
End Sub
Private Sub findFiler(mappesti)
Dim fs, f, f1, fc, fNavn As String, svar As Integer

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(mappesti)
    Set fc = f.Files
   
    For Each f1 In fc
Rem hvis søgte navn - spørg om justeres
        If LCase(f1.Name) = LCase(filNavn) Then
            svar = MsgBox("Skal fil justeres?", vbYesNo, mappesti & "\" & f1.Name)
            If svar = 6 Then
                Workbooks.Open mappesti & "\" & filNavn
                ActiveWorkbook.Sheets("Relevans").Activate
                ActiveSheet.Range("E10") = ""
                ActiveSheet.Range("E11") = "JA"
                ActiveWorkbook.Save
                ActiveWorkbook.Close
               
                opdaterListeMedFiler mappesti & "\" & f1.Name
            End If
        End If
    Next
End Sub
Private Sub opdaterListeMedFiler(sti)
    With system.Sheets(arkListeMedFiler)
        .Range("A" & antalRækker) = sti
        antalRækker = antalRækker + 1
    End With
End Sub

Så fik jeg mulighed for at teste.
Det er super godt.
Så har jeg et godt overblik over hvilke mapper / filer der er rettet.

Endnu engang mange tak for hjælpen :-)

selv tak - en fornøjelse..