Tìm file .xlsm trong subfolder và copy + rename đến nơi khác

hadoan-pap · 7/11/19

Em chào mọi người

Em có bài toán rất mong mọi người hỗ trợ ạ.

Trong đường dẫn : C:\File có khá nhiều sub-folder.... nhưng chỉ có 1 file .xlsm ở trong bất kỳ 1 thư mục con nào đó.

Em muốn tìm file *.xlsm trong toàn bộ đường dẫn C:\File và sau đó copy + rename đến 1 nơi khác.

Rất mong được mọi người giúp ạ.

Em xin cảm ơn!

hadoan-pap · 8/11/19

Em có đoạn code này nhưng nó dang không copy file được...

Rất mong mọi ng hỗ trợ ạ.

Dim FSO As Object, fld As Object
Dim fsoFile As Object
Dim fsoFol As Object

SourcePath = "C:\Users\Administrator\Desktop\Test Copy\Source"
targetPath = "C:\Users\Administrator\Desktop\Test Copy\Dest"

Set FSO = CreateObject("Scripting.FileSystemObject")
Set fld = FSO.GetFolder(SourcePath)
If FSO.FolderExists(fld) Then
For Each fsoFol In FSO.GetFolder(SourcePath).SubFolders
For Each fsoFile In fsoFol.Files
If Right(fsoFile, 1) = "xlsm" Then
fsoFile.Copy targetPath
End If
Next
Next
End If

Bài đã được tự động gộp: 8/11/19

Dim StrFile As String
Dim objFSO, destRow As Long
Dim mFolder, mainFolder, mySubFolder
Dim arow As Long
Dim TargetFolder As String
Dim File As Object

Set objFSO = CreateObject("Scripting.FileSystemObject")
mFolder = "C:\Users\Administrator\Desktop\Test Copy\Source\"
TargetFolder = "C:\Users\Administrator\Desktop\Test Copy\Dest"
Set mainFolder = objFSO.GetFolder(mFolder)

For Each mySubFolder In mainFolder.SubFolders
StrFile = Dir(mySubFolder & "\*.xlsm")
For Each File In StrFile
Sheet1.Cells(1, 1).Value = mySubFolder & "\" & StrFile
File.Copy TargetFolder
Next
Next

HieuCD · 8/11/19

hadoan-pap đã viết:
Em chào mọi người

Em có bài toán rất mong mọi người hỗ trợ ạ.

Trong đường dẫn : C:\File có khá nhiều sub-folder.... nhưng chỉ có 1 file .xlsm ở trong bất kỳ 1 thư mục con nào đó.

Em muốn tìm file *.xlsm trong toàn bộ đường dẫn C:\File và sau đó copy + rename đến 1 nơi khác.

Rất mong được mọi người giúp ạ.

Em xin cảm ơn!

Chạy Sub trong file

Mã:

Sub Move_Rename_File_Xlsm()
  Dim sPath$, dPath$, strNewFile$

  strNewFile = "TamThoiNha.xlsm" 'Ten File moi
  With Application.FileDialog(msoFileDialogFolderPicker)
      .Title = "Chon Folder Nguon chua file can Doi Ten"
      .AllowMultiSelect = False
      .Show
      If .SelectedItems.Count = 0 Then
        MsgBox "Chua Chon Folder Nguon", vbInformation
        Exit Sub
      End If
      sPath = .SelectedItems(1) 'Folder Nguon
  End With
  With Application.FileDialog(msoFileDialogFolderPicker)
      .Title = "Chon Folder Di Chuyen file can Doi Ten"
      .AllowMultiSelect = False
      .Show
      If .SelectedItems.Count = 0 Then
        MsgBox "Chua Chon Folder Dích, lam lai tu dau", vbInformation
        Exit Sub
      End If
      dPath = .SelectedItems(1) 'Folder Dích
  End With
  Call XuLy(sPath, dPath, strNewFile)
End Sub

Private Sub XuLy(ByVal sPath$, ByVal dPath$, ByVal strNewFile$)
    Dim sFolder As Object, subFolder As Object, iFile As Object
    Dim iFileName$, ThisFileName$
    ThisFileName = ThisWorkbook.Name
    With CreateObject("Scripting.filesystemobject")
      Set sFolder = .GetFolder(sPath).SubFolders
      If .GetFolder(sPath).Files.Count > 0 Then
        For Each iFile In .GetFolder(sPath).Files
          iFileName = iFile.Name
          If iFileName Like "*.xlsm" Then
            If Left(iFileName, 1) <> "~" Then
              If iFileName <> ThisFileName Then
                .MoveFile sPath & "\" & iFileName, dPath & "\" & strNewFile
                MsgBox "Finish", vbInformation
                Exit Sub
              End If
            End If
          End If
        Next iFile
      End If
      If sFolder.Count > 0 Then
        For Each subFolder In sFolder
          Call XuLy(subFolder, dPath, strNewFile)
        Next
      End If
    End With
End Sub

hadoan-pap · 8/11/19

HieuCD đã viết:

Chạy Sub trong file

Mã:

Sub Move_Rename_File_Xlsm()
  Dim sPath$, dPath$, strNewFile$

  strNewFile = "TamThoiNha.xlsm" 'Ten File moi
  With Application.FileDialog(msoFileDialogFolderPicker)
      .Title = "Chon Folder Nguon chua file can Doi Ten"
      .AllowMultiSelect = False
      .Show
      If .SelectedItems.Count = 0 Then
        MsgBox "Chua Chon Folder Nguon", vbInformation
        Exit Sub
      End If
      sPath = .SelectedItems(1) 'Folder Nguon
  End With
  With Application.FileDialog(msoFileDialogFolderPicker)
      .Title = "Chon Folder Di Chuyen file can Doi Ten"
      .AllowMultiSelect = False
      .Show
      If .SelectedItems.Count = 0 Then
        MsgBox "Chua Chon Folder Dích, lam lai tu dau", vbInformation
        Exit Sub
      End If
      dPath = .SelectedItems(1) 'Folder Dích
  End With
  Call XuLy(sPath, dPath, strNewFile)
End Sub

Private Sub XuLy(ByVal sPath$, ByVal dPath$, ByVal strNewFile$)
    Dim sFolder As Object, subFolder As Object, iFile As Object
    Dim iFileName$, ThisFileName$
    ThisFileName = ThisWorkbook.Name
    With CreateObject("Scripting.filesystemobject")
      Set sFolder = .GetFolder(sPath).SubFolders
      If .GetFolder(sPath).Files.Count > 0 Then
        For Each iFile In .GetFolder(sPath).Files
          iFileName = iFile.Name
          If iFileName Like "*.xlsm" Then
            If Left(iFileName, 1) <> "~" Then
              If iFileName <> ThisFileName Then
                .MoveFile sPath & "\" & iFileName, dPath & "\" & strNewFile
                MsgBox "Finish", vbInformation
                Exit Sub
              End If
            End If
          End If
        Next iFile
      End If
      If sFolder.Count > 0 Then
        For Each subFolder In sFolder
          Call XuLy(subFolder, dPath, strNewFile)
        Next
      End If
    End With
End Sub

Gửi anh .

Em có đoạn code như bên dưới... em đã tìm dc đích danh file em muốn rồi ạ..

Nhưng em có thử để copy nó đủ kiểu đi nơi khác mà k hiểu sao toàn báo lỗi... không rõ có nhầm đâu không ạ ?

Anh xem giúp em với nhé.

Em cảm ơn anh.

Dim StrFile As String
Dim objFSO, destRow As Long
Dim mFolder, mainFolder, mySubFolder
Dim TargetFolder As String
Dim file As Object
Dim FSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
mFolder = "C:\Users\Administrator\Desktop\Test Copy\Source\Sub-folder"
TargetFolder = "C:\Users\Administrator\Desktop\Test Copy\Dest"
Set mainFolder = objFSO.GetFolder(mFolder)

For Each mySubFolder In mainFolder.SubFolders
''StrFile = Dir(mySubFolder & "\*.xlsm")

For Each file In mySubFolder.Files

Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.CopyFile Source:=mFolder & file, Destination:=TargetFolder

Next

Next

HieuCD · 8/11/19

hadoan-pap đã viết:
Gửi anh .

Em có đoạn code như bên dưới... em đã tìm dc đích danh file em muốn rồi ạ..

Nhưng em có thử để copy nó đủ kiểu đi nơi khác mà k hiểu sao toàn báo lỗi... không rõ có nhầm đâu không ạ ?

Anh xem giúp em với nhé.

Em cảm ơn anh.

Dim StrFile As String
Dim objFSO, destRow As Long
Dim mFolder, mainFolder, mySubFolder
Dim TargetFolder As String
Dim file As Object
Dim FSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
mFolder = "C:\Users\Administrator\Desktop\Test Copy\Source\Sub-folder"
TargetFolder = "C:\Users\Administrator\Desktop\Test Copy\Dest"
Set mainFolder = objFSO.GetFolder(mFolder)

For Each mySubFolder In mainFolder.SubFolders
''StrFile = Dir(mySubFolder & "\*.xlsm")

For Each file In mySubFolder.Files

Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.CopyFile Source:=mFolder & file, Destination:=TargetFolder

Next

Next

Dùng code của mình nha

hadoan-pap · 8/11/19

gửi anh @HieuCD

Cảm ơn a nhiều nhe.

E customize lại rồi ạ.

quanluu · 8/11/19

hadoan-pap đã viết:
Em chào mọi người

Em có bài toán rất mong mọi người hỗ trợ ạ.

Trong đường dẫn : C:\File có khá nhiều sub-folder.... nhưng chỉ có 1 file .xlsm ở trong bất kỳ 1 thư mục con nào đó.

Em muốn tìm file *.xlsm trong toàn bộ đường dẫn C:\File và sau đó copy + rename đến 1 nơi khác.

Rất mong được mọi người giúp ạ.

Em xin cảm ơn!

cái này vba làm gì cho đau đầu nhỉ, bạn cần search và copy là được.

snow25 · 8/11/19

quanluu1989 đã viết:
cái này vba làm gì cho đau đầu nhỉ, bạn cần search và copy là được.

Khả năng là bạn này có 1 file trên ổ chung của công ty mọi người gửi file vào đó.Giờ bạn đó cần copy về foder của mình nhưng chắc là làm đi làm lại nhiều lần chán.Nên dùng code cho nhanh.

hadoan-pap · 15/11/19

snow25 đã viết:
Khả năng là bạn này có 1 file trên ổ chung của công ty mọi người gửi file vào đó.Giờ bạn đó cần copy về foder của mình nhưng chắc là làm đi làm lại nhiều lần chán.Nên dùng code cho nhanh.

Hi cậu.

Tớ dung script do Nhu cầu nên không thể làm tay được , do đó cần dung Code ^^

ppc0312 · 15/11/19

hadoan-pap đã viết:
Hi cậu.

Tớ dung script do Nhu cầu nên không thể làm tay được , do đó cần dung Code ^^

Dùng Script thì viết luôn trong script, sao lại VBA cho vòng vèo

batman1 · 15/11/19

hadoan-pap đã viết:
Gửi anh .
Em có đoạn code như bên dưới... em đã tìm dc đích danh file em muốn rồi ạ..
Nhưng em có thử để copy nó đủ kiểu đi nơi khác mà k hiểu sao toàn báo lỗi... không rõ có nhầm đâu không ạ ?
Anh xem giúp em với nhé.

Không được mời nên hơi vô duyên. Nhưng thôi, góp ý cho bạn.

1. Đối tượng fso chỉ tạo 1 lần duy nhất. Vì thế không ai đặt trong vòng lặp (vd. FOR) cả. Hãy chuyển Set FSO = CreateObject("Scripting.FileSystemObject") lên trước FOR đầu tiên.

2. Không phải
Source:=mFolder & file

mà là
Source:=file

vì file đã là đường dẫn đầy đủ rồi.

3.
Hoặc sửa

Destination:=TargetFolder

thành

Destination:=TargetFolder & "\"

hoặc sửa

TargetFolder = "C:\Users\Administrator\Desktop\Test Copy\Dest"

thành

TargetFolder = "C:\Users\Administrator\Desktop\Test Copy\Dest\"

Nên sửa theo cách 2 vì không ai làm chuyện nối chuỗi (&) trong vòng lặp cả.

Tìm file .xlsm trong subfolder và copy + rename đến nơi khác

hadoan-pap

Thành viên tiêu biểu

hadoan-pap

Thành viên tiêu biểu

HieuCD

Chuyên gia GPE

File đính kèm

hadoan-pap

Thành viên tiêu biểu

HieuCD

Chuyên gia GPE

hadoan-pap

Thành viên tiêu biểu

quanluu

Thành viên gắn bó

snow25

Thành viên gạo cội

hadoan-pap

Thành viên tiêu biểu

ppc0312

whom?

batman1

Thành viên gạo cội

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian