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

Nguyen Anh Dung

Board Regular
Joined
Feb 28, 2020
Messages
148
Office Version
  1. 2016
Platform
  1. Windows
i have code count total image in subfolder . i count about 17000 file JPG. Help me to edit code counts faster!!!
Code:
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
 

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.

diddi

Well-known Member
Joined
May 20, 2004
Messages
3,337
Office Version
  1. 2010
Platform
  1. Windows
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

VBA Code:
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

Board Regular
Joined
Feb 28, 2020
Messages
148
Office Version
  1. 2016
Platform
  1. Windows
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

VBA Code:
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

Board Regular
Joined
Feb 28, 2020
Messages
148
Office Version
  1. 2016
Platform
  1. Windows
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

VBA Code:
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

Well-known Member
Joined
May 20, 2004
Messages
3,337
Office Version
  1. 2010
Platform
  1. Windows
there must be a probelm with your path.
try "C:\" just to see if it is working
 

Forum statistics

Threads
1,144,663
Messages
5,725,658
Members
422,635
Latest member
crisis

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top