Traversering af jpg-filer for at finde redundante blandt 15k stk

Denne marko henter flg. til hhv. kolonne A, B, C og D:
A = Filnavn
B = Mappenavn
C = Filstørrelse
D = Fil sidst ændret
********************************
Public Sub VisAlleFilerIMappen()
    Dim objFS As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim i As Long
   
    Set objFS = CreateObject("Scripting.Filesystemobject")
    Set objFolder = objFS.GetFolder("SKRIV STIEN HER")
   
    i = 1
   
    For Each objFile In objFolder.Files
        ActiveSheet.Cells(i, 1) = objFile.Name
        ActiveSheet.Cells(i, 2) = objFolder.Name
        ActiveSheet.Cells(i, 3) = objFile.Size
        ActiveSheet.Cells(i, 4) = objFile.DateLastModified
        i = i + 1
    Next objFile
   
    Set objFS = Nothing
    Set objFolder = Nothing
End Sub
********************************
Bemærk at du selv skal angive navnet på den placering hvor du ønsker filerne listet fra.
Jeg håber at dette kan hjælpe dig videre.
/Be_Nice

Jeg lod mig inspirere af ovenstående samt af:
http://www.dailydoseofexcel.com/archives/2005/02/25/searching-files-in-subfolders-for-vba-code-string/

Og lavede selv følgende kode:
Min kode er lidt tung, og hvis man kunne undgå linjen m. fx
Set myFileObject = myFSO.GetFile(.FoundFiles(i))

så tror jeg det performer noget hurtigere?


'Needs a reference to Microsoft Visual Basic for Applications Extensibility
Sub FindAndWriteJPGFilesInExcel()
    Const cFile = "*.jp*"
   

    Dim i As Long, rng As Range, wkb As Workbook
    Dim strFile As String, lngStartLine As Long, lngStartCol As Long
    Dim xCalc As XlCalculation, blnEvents As Boolean
    Dim cFolder As String ' cell containing path to be searched
    Dim myFSO, myFileObject

    cFolder = Range("Source")
    Set myFSO = CreateObject("Scripting.FileSystemObject")

    With Application.FileSearch
        .NewSearch
        .LookIn = cFolder
        .Filename = cFile
        .SearchSubFolders = Range("searchsubfolders").Value ' At test run i did not want to include the whole tree
        .MatchTextExactly = True
        .FileType = msoFileTypeAllFiles

        If .Execute() > 0 Then


            On Error GoTo errwkb
            For i = 1 To .FoundFiles.Count
                Application.ScreenUpdating = False
                Set myFileObject = myFSO.GetFile(.FoundFiles(i))
                With myFileObject
                    Range("destination").Offset(i, 1) = .Name
                    Range("destination").Offset(i, 2) = .DateCreated
                    Range("destination").Offset(i, 3) = .datelastmodified
                    Range("destination").Offset(i, 4) = .Path
                    Range("destination").Offset(i, 5) = .Size
                End With
                Set myFileObject = Nothing
                If (i Mod 1000 = 0) Then
                    MsgBox i ' this line I put a break mark on, since the code slowed my PC down, then for every 1000 pics i regained CPU control
                End If
                Debug.Print i
            Next i
                Application.ScreenUpdating = True

End Sub

be nice - smider du et svar, så deler vi point.