Chào anh chị, nhờ anh chị sửa code để chạy nhanh hơn!!!

Liên hệ QC

nguyenanhdung8111982

Thành viên hoạt động
Tham gia
1/11/19
Bài viết
120
Được thích
33
Giới tính
Nam
Em có đoạn code như dưới dùng để đếm tổng số file hình có đuôi mở rộng là '.jpg' hoặc '.JPG' trong từng subfolder. em đếm khoảng 17k hình. nhờ anh chị giúp chỉnh sửa code để chạy nhanh hơn!!!
Mã:
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
Trân trọng,
Nguyen Anh Dung
 
Em có đoạn code như dưới dùng để đếm tổng số file hình có đuôi mở rộng là '.jpg' hoặc '.JPG' trong từng subfolder. em đếm khoảng 17k hình. nhờ anh chị giúp chỉnh sửa code để chạy nhanh hơn!!!

Bạn dùng hàm Dir() xem sao.

Mã:
Public Function countFiles(strDir As String, Optional strType As String) As Long
    Dim file As String, i As Long
    If Right(strDir, 1) <> "\" Then strDir = strDir & "\"
    file = Dir(strDir & strType)
    While (file <> "")
        i = i + 1
        file = Dir
    Wend
    countFiles = i
End Function

Áp dụng:

Mã:
Sub Test()
    Msgbox countFiles("D:\Hinh\", "*.jpg*")
End Sub
 
Em có đoạn code như dưới dùng để đếm tổng số file hình có đuôi mở rộng là '.jpg' hoặc '.JPG' trong từng subfolder. em đếm khoảng 17k hình. nhờ anh chị giúp chỉnh sửa code để chạy nhanh hơn!!!
Mã:
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
Trân trọng,
Nguyen Anh Dung
Chạy code
Mã:
Option Compare Text

Sub Demfile_JPG()
  Dim Res(0 To 100000, 1 To 4)
  Dim k As Long, FolderName As String

  With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    If .SelectedItems.Count = 0 Then MsgBox ("Phai Chon Thu Muc!"): Exit Sub
    FolderName = .SelectedItems(1)
  End With
  Application.ScreenUpdating = False
  If FolderName <> Empty Then
    Res(0, 1) = "Source":       Res(0, 2) = "Folder"
    Res(0, 3) = "Subfolder":    Res(0, 4) = "FileCount"
    
    Call ListFolders(Res, k, FolderName)
    Range("A1").Resize(k + 1, 4) = Res
    MsgBox "Done" & vbCrLf & "Total files found: " & k
  End If
  Application.ScreenUpdating = True
End Sub

Private Sub ListFolders(ByRef Res, ByRef k, ByVal Fldr As String)
  Dim fs As Object, fd As Object, fdSub As Object
 
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set fd = fs.GetFolder(Fldr)
  For Each fdSub In fd.SubFolders
    k = k + 1
    Res(k, 1) = Replace(Fldr, fd.Name, "")
    Res(k, 2) = fd.Name
    Res(k, 3) = fdSub.Name
    Res(k, 4) = 0
    Call CountFiles(Res, k, Fldr & "\" & fdSub.Name)
    Call ListFolders(Res, k, fdSub.Path)
  Next
  Set fs = Nothing:   Set fd = Nothing:   Set fdSub = Nothing
End Sub

Private Sub CountFiles(ByRef Res, ByRef k, ByVal strDirectory As String)
  Dim objFSO As Object, objFiles As Object, objFile As Object

  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objFiles = objFSO.GetFolder(strDirectory).Files
  For Each objFile In objFiles
    If Right(objFile.Path, 4) = ".JPG" Then
      Res(k, 4) = Res(k, 4) + 1
    End If
  Next objFile
  Set objFSO = Nothing:   Set objFiles = Nothing
End Sub
 
Chạy code
Mã:
Option Compare Text

Sub Demfile_JPG()
  Dim Res(0 To 100000, 1 To 4)
  Dim k As Long, FolderName As String

  With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    If .SelectedItems.Count = 0 Then MsgBox ("Phai Chon Thu Muc!"): Exit Sub
    FolderName = .SelectedItems(1)
  End With
  Application.ScreenUpdating = False
  If FolderName <> Empty Then
    Res(0, 1) = "Source":       Res(0, 2) = "Folder"
    Res(0, 3) = "Subfolder":    Res(0, 4) = "FileCount"
   
    Call ListFolders(Res, k, FolderName)
    Range("A1").Resize(k + 1, 4) = Res
    MsgBox "Done" & vbCrLf & "Total files found: " & k
  End If
  Application.ScreenUpdating = True
End Sub

Private Sub ListFolders(ByRef Res, ByRef k, ByVal Fldr As String)
  Dim fs As Object, fd As Object, fdSub As Object

  Set fs = CreateObject("Scripting.FileSystemObject")
  Set fd = fs.GetFolder(Fldr)
  For Each fdSub In fd.SubFolders
    k = k + 1
    Res(k, 1) = Replace(Fldr, fd.Name, "")
    Res(k, 2) = fd.Name
    Res(k, 3) = fdSub.Name
    Res(k, 4) = 0
    Call CountFiles(Res, k, Fldr & "\" & fdSub.Name)
    Call ListFolders(Res, k, fdSub.Path)
  Next
  Set fs = Nothing:   Set fd = Nothing:   Set fdSub = Nothing
End Sub

Private Sub CountFiles(ByRef Res, ByRef k, ByVal strDirectory As String)
  Dim objFSO As Object, objFiles As Object, objFile As Object

  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objFiles = objFSO.GetFolder(strDirectory).Files
  For Each objFile In objFiles
    If Right(objFile.Path, 4) = ".JPG" Then
      Res(k, 4) = Res(k, 4) + 1
    End If
  Next objFile
  Set objFSO = Nothing:   Set objFiles = Nothing
End Sub
Cám ơn bạn, cách này chạy cũng chậm giống như của mình. Cám ơn bạn!!!
Bài đã được tự động gộp:

Em đoán chủ thớt tìm tới FileSystemObject vì vụ đường dẫn có ký tự có dấu. Dir() không xử lý được vụ đó.
Đường dẫn thư mục không có dấu bạn ơi!!!
ý mình là có thể cải thiện vòng lặp nào để chạy nhanh hơn!!!
 
Bao nhiêu lâu thì mí được gọi là nhanh????
 
Cám ơn bạn, cách này chạy cũng chậm giống như của mình. Cám ơn bạn!!!
Bài đã được tự động gộp:


Đường dẫn thư mục không có dấu bạn ơi!!!
ý mình là có thể cải thiện vòng lặp nào để chạy nhanh hơn!!!
Mình test với 200 thư mục tốc độ code của mình nhanh gần 2 lần code gốc
 
Cái này sao không dùng command line bạn?
Dir /s /b "đường dẫn" *.jpg | find /c ":"
 
Web KT
Back
Top Bottom