[Help] VBA quét tất cả thư mục con và copy Photo

[ngoctuyen1995]

Thân chào cả nhà GPEX..!
Mong cả nhà giúp đỡ em ạ..
Hiện tại đã có một Macro để tìm kiếm Photo nhưng lại bị hạn chế, Macro chỉ quét được 01 Folder mình chỉ tới, Em đã mò mẫn ở các diễn đàn nhưng không tìm được cách sửa, Mong cả nhà giúp em ạ..

Em muốn khi chạy Macro link tới 01 Folder tổng, Trong Folder Tổng có các Folder Con, em muốn quét luôn tất cả các thư mục con đó để tìm kiếm Photo theo điều kiện của cột B và copy các photo tìm được qua Thư muc khác.. (Macro của em đã làm được nhưng nó chỉ quét được 01 Folder thôi ạ)
Em gửi File đính kèm có cả macro bên dưới, mong cả nhà giúp đỡ ạ...

 

[ngoctuyen1995]

Mong cả nhà giúp đỡ ạ..

 

[HeSanbi]

Bạn mô tả ý định của bạn và file upload không rõ ràng, bạn cần upload 1 file excel chính và 1 thư mục tổng chứa các thư mục chứa hình ảnh,
Có khi nào phải mở hết tất cả các file excel, và tự tìm yêu cầu của bạn chăng.

Dưới đây là đoạn code quét toàn bộ thư mục con

'Thêm Tool: Microsoft Scripting Runtime
Public FSO As Scripting.FileSystemObject
Public SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Public FileItem As Scripting.File
Public Const MainFolder = "D:\Data\Picture\"
Public Const ToFolder = "D:\Data\New\"

Public Sub SapXepFile()
  Set FSO = New Scripting.FileSystemObject
'Nếu thư mục mới không có thì tạo mới (Bỏ dấu nháy đơn để dòng code hoạt động)
  'If Not FSO.FolderExists(ToFolder) Then
  '  FSO.CreateFolder ToFolder
  'End If
  ListFilesInFolder FSO.GetFolder(MainFolder), True
  Set FileItem = Nothing
  Set SourceFolder = Nothing
  Set FSO = Nothing
End Sub
'Thủ tục tìm tất cả các file trong thư mục con
Public Sub ListFilesInFolder( _
              ByVal SourceFolder As Scripting.Folder, _
              ByVal IncludeSubfolders As Boolean)
  On Error Resume Next
  Dim FileFolder$
  For Each FileItem In SourceFolder.Files
    'Code cần thực hiện bắt đầu từ đây
    'Copy File vào thư mục chứa
    'Thêm điều kiện để di chuyển file: (Bỏ dấu nháy đơn để dòng code hoạt động)
    'If FileItem.ShortName Like "*.png*" _
     Or FileItem.ShortName Like "*.jpg*" Then
        FSO.CopyFile FileItem.Path, ToFolder & "\" & FileItem.Name, True
    'End If
  Next FileItem
  If IncludeSubfolders Then
    For Each SubFolder In SourceFolder.SubFolders
      ListFilesInFolder SubFolder, True
    Next SubFolder
  End If
End Sub