help edit code count total image in subfolder faster!!!

[Nguyen Anh Dung]

i have code count total image in subfolder . i count about 17000 file JPG. Help me to edit code counts faster!!!

Sub DemfileJPG1()
Application.ScreenUpdating = False
Dim FolderName As String
Sheets("sheet1").Select
Cells(1, 1).Value = 2
With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        '.Title = "Select an image file"
        .Show
        '.AllowMultiSelect = True
        .Filters.Clear
        '.Filters.Add "JPG", ".JPG"
        '.Filters.Add "JPEG File Interchange Format", ".JPEG"
    On Error Resume Next
    FolderName = .SelectedItems(1)
    Err.Clear
    On Error GoTo 0
End With
ListFolders (FolderName)
Application.ScreenUpdating = True
MsgBox "Done" & vbCrLf & "Total files found: " & Cells(1, 1).Value
Cells(1, 1).Value = "Source"
Cells(1, 2).Value = "Folder"
Cells(1, 3).Value = "Subfolder"
Cells(1, 4).Value = "FileCount"
End Sub

Sub ListFolders(Fldr As String)
Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
Dim fl1
    Set fl1 = CreateObject("Scripting.FileSystemObject")
Dim fl2
    Set fl2 = CreateObject("Scripting.FileSystemObject")
Set fl1 = fs.GetFolder(Fldr)
For Each fl2 In fl1.SubFolders
    Cells(Cells(1, 1).Value, 1).Value = Replace(Fldr, fl1.Name, "")
    Cells(Cells(1, 1).Value, 2).Value = fl1.Name
    Cells(Cells(1, 1).Value, 3).Value = fl2.Name
    Cells(Cells(1, 1).Value, 4).Value = CountFiles(Fldr & "\" & fl2.Name)
    Cells(1, 1).Value = Cells(1, 1).Value + 1
    ListFolders fl2.Path
Next
End Sub


Private Function CountFiles(strDirectory As String, Optional strExt As String = ".JPG", Optional strExt1 As String = ".jpg") As Double

'Private Function CountFiles(strDirectory As String, Optional strExt As String = ".JPG") As Double
'Author          : Ken Puls (www.excelguru.ca)
'Function purpose: To count files in a directory.  If a file extension is provided,
'   then count only files of that type, otherwise return a count of all files.
    Dim objFSO As Object
    Dim objFiles As Object
    Dim objFile As Object

    'Set Error Handling
    On Error GoTo EarlyExit

    'Create objects to get a count of files in the directory
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFiles = objFSO.GetFolder(strDirectory).Files

    'Count files (that match the extension if provided)
    'If strExt = "*.*" Then
    'If strExt <> ".jpg" Or strExt1 <> ".JPG" Then
    'If strExt = ".JPG" Or strExt1 = ".jpg" Then
    'If strExt = ".JPG" Then
    If strExt = ".csv" Then
    'If strExt = ".JPG" Then
        CountFiles = objFiles.Count
    Else
        For Each objFile In objFiles

            'If UCase(Right(objFile.Path, (Len(objFile.Path) - InStrRev(objFile.Path, ".")))) = UCase(strExt) Then
            'If UCase(Right(objFile.Path, (Len(objFile.Path) - InStrRev(objFile.Path, ".JPG")))) = UCase(strExt) Then
            If Right(objFile.Path, 4) = ".JPG" Or Right(objFile.Path, 4) = ".jpg" Then
              'If UCase(objFile.Path) Like ".JPG" Then
               CountFiles = CountFiles + 1
            End If
        Next objFile
'Loop
    End If

EarlyExit:
    'Clean up
    On Error Resume Next
    Set objFile = Nothing
    Set objFiles = Nothing
    Set objFSO = Nothing
    On Error GoTo 0
End Function

Best regards,
Nguyen Anh Dung

 

[diddi]

hi. this will be of interest to you.
it can rip 10,000 file in about 2 seconds. you can mod as you need. who says DOS is dead LOL

Sub FileAndFolderTree()
    Dim TopFolder As String, TempFile As String, WshShell, CMD As String, ErrCode As Long
    
    Set WshShell = CreateObject("WScript.Shell")
    
    TopFolder = "C:\" ' change as needed
    TempFile = "D:\Tree.txt"
    
    CMD = "CMD /c tree " & Chr(34) & TopFolder & Chr(34) & " > " & Chr(34) & TempFile & Chr(34) & " /F"

    ErrCode = WshShell.Run(CMD, xlHidden, True)
    
    If Not ErrCode = 0 Then
        MsgBox "Tree CMD Shell Error " & lErrCode
    Else
        Workbooks.OpenText Filename:=TempFile, Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
            ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:=ChrW(&H2502), _
            FieldInfo:=Array(Array(1, 1), Array(2, 1))
    End If
End Sub

 

[Nguyen Anh Dung]

hi. this will be of interest to you.
it can rip 10,000 file in about 2 seconds. you can mod as you need. who says DOS is dead LOL

Sub FileAndFolderTree()
    Dim TopFolder As String, TempFile As String, WshShell, CMD As String, ErrCode As Long
   
    Set WshShell = CreateObject("WScript.Shell")
   
    TopFolder = "C:\" ' change as needed
    TempFile = "D:\Tree.txt"
   
    CMD = "CMD /c tree " & Chr(34) & TopFolder & Chr(34) & " > " & Chr(34) & TempFile & Chr(34) & " /F"

    ErrCode = WshShell.Run(CMD, xlHidden, True)
   
    If Not ErrCode = 0 Then
        MsgBox "Tree CMD Shell Error " & lErrCode
    Else
        Workbooks.OpenText Filename:=TempFile, Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
            ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:=ChrW(&H2502), _
            FieldInfo:=Array(Array(1, 1), Array(2, 1))
    End If
End Sub

Yes, thanks you!!!

 

[Nguyen Anh Dung]

hi. this will be of interest to you.
it can rip 10,000 file in about 2 seconds. you can mod as you need. who says DOS is dead LOL

Sub FileAndFolderTree()
    Dim TopFolder As String, TempFile As String, WshShell, CMD As String, ErrCode As Long
   
    Set WshShell = CreateObject("WScript.Shell")
   
    TopFolder = "C:\" ' change as needed
    TempFile = "D:\Tree.txt"
   
    CMD = "CMD /c tree " & Chr(34) & TopFolder & Chr(34) & " > " & Chr(34) & TempFile & Chr(34) & " /F"

    ErrCode = WshShell.Run(CMD, xlHidden, True)
   
    If Not ErrCode = 0 Then
        MsgBox "Tree CMD Shell Error " & lErrCode
    Else
        Workbooks.OpenText Filename:=TempFile, Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
            ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:=ChrW(&H2502), _
            FieldInfo:=Array(Array(1, 1), Array(2, 1))
    End If
End Sub

i have change path:
TopFolder = "E:\TanPhuc\" ' change as needed
TempFile = "E:\TanPhuc\Tree.csv"

and result:

Folder PATH listing for volume Relax

Volume serial number is 3840-35CC

E:\TANPHUC\

Invalid path - \TANPHUC\

No subfolders exist

i not see count.

Best regards,
Nguyen Anh Dung

 

[diddi]

there must be a probelm with your path.
try "C:\" just to see if it is working