List filer i mappe i et regneark

Denne makro beder brugeren om at indtaste stien til en mappe, fx C:\USA. Dernæst skal man tage stilling til, om eventuelle filer i undermapper skal listes. Når der klikkes OK til sidst, listes den alle de filer, der findes i den angivne mappe (evt. med tilhørende undermapper) i A-kolonnen i det aktive ark. Det anbefales at starte med et tomt ark, da eventuelle værdier i A-kolonnen overskrives. Er mappen tom, eller eksisterer den slet ikke, vises en fejlmeddelelse.

Sub ListFiler()

    Dim Mappe As String
    Dim Undermapper As Boolean

    Mappe = InputBox("Indtast sti til mappe" & vbCrLf _
      & "Fx C:\USA")
        If MsgBox("Skal undermappers indhold også listes?", _
          vbYesNo + vbQuestion) = vbYes Then
            Undermapper = True
        Else
            Undermapper = False
        End If

    Set fs = Application.FileSearch
    With fs
        .LookIn = Mappe
        .SearchSubFolders = Undermapper
        .Filename = "*"
        If .Execute() > 0 Then
            Range("a1").Select
            For i = 1 To .FoundFiles.Count
                ActiveCell.Value = .FoundFiles(i)
                ActiveCell.Offset(1, 0).Select
            Next i
        Else
            MsgBox "Mappen findes ikke, eller den er tom", vbOKOnly + vbExclamation
        End If
    End With
End Sub

Makroen virker desværre ikke i Excel 2007 og 2010, hvor VBA funktionen Application.Filesearch er fjernet (med den begrundelse, at den kun blev anvendt af meget avancerede Excel brugere. Tak Microsoft! :-))

Her er en funktion der virker. Den er baseret på den meget gamle funktion DIR, som fortsat virker, men som desværre ikke kan tag e undermapper med, så her må man køre makroen i flere omgange, og så¨selkv specificere den relevante undermappe i hver kørsel.

Sub ListFiler()

    Dim Undersoeg As String
    Undersoeg = Dir(InputBox("Indtast sti til mappe" & vbCrLf _
       & "Fx C:\USA") & "\*.*")
    Do While Len(Undersoeg) > 0
        ActiveCell.Value = sFName
        ActiveCell.Offset(1, 0).Select
        Undersoeg = Dir
    Loop
End Sub

- Til top -
- Tilbage til makroer -
- Tilbage til Excel -