Nhờ anh chị giúp sửa code kiểm tra thư mục không tồn tại thì tạo và di chuyển file cùng tên vào (1 người xem)

nguyenanhdung8111982 · 13/12/20

em có đường dẫn nguồn fromPath = "C:\Users\Admin\Desktop\CG\" bao gồm file csv như dưới
20200425_06_002_QGV_GS013858_01_360_updated_0
20200425_06_002_QGV_GS013858_01_updated_0
20200425_06_001_QGV_GS013858_01_updated_0
và đường dẫn đích có 2 folder
toPath = "C:\Users\Admin\Desktop\Test\"
20200425_06_001_QGV_GS013858_01
20200425_06_002_QGV_GS013858_01
Trong trường hợp folder tồn tại thì move file vô ổn.
nhưng khi folder không tồn tại thì em có dùng tạo thư mục và move file vô thì kết quả không đúng
If Len(Dir(toSubPath, vbDirectory)) = 0 Then MkDir toSubPath
đây là đoạn code nhờ anh chị sửa:

Mã:

Option Explicit
Sub MoveFiles()
Dim fName As String, fromPath As String, toPath As String
Dim toSubPath As String, cnt As Long
Dim toSubPath1 As String, cnt1 As Long
On Error Resume Next
'fromPath = Application.InputBox("Nhap duong dan nguon: ")
'toPath = Application.InputBox("Nhap duong dan dich: ")

toPath = "C:\Users\Admin\Desktop\Test\" 'duong dan muon move den
fromPath = "C:\Users\Admin\Desktop\CG\" 'duong dan chua file csv

fName = Dir(fromPath & "*.csv")
Do While Len(fName) > 10
         
    If Right(fName, 14) = "_updated_0.csv" Then
    cnt = 0
    toSubPath = toPath & Left(fName, Len(fName) - 14) & "\"
    'If Len(Dir(toSubPath, vbDirectory)) = 0 Then MkDir toSubPath
   'If Dir(toSubPath, vbDirectory) = "" Then MkDir toSubPath

    Name (fromPath & fName) As (toSubPath & fName)
       
    End If
    If Right(fName, 18) = "_360_updated_0.csv" Then
    cnt = 0
    toSubPath = toPath & Left(fName, Len(fName) - 18) & "\"

    Name (fromPath & fName) As (toSubPath & fName)
       
    End If
    fName = Dir
Loop
 
MsgBox "Ho" & ChrW(224) & "n Th" & ChrW(224) & "nh !!!"
cnt = cnt + 1


End Sub

trân trọng

Maika8008 · 14/12/20

Bạn thử chạy step by step xem chỗ nào chạy không đúng!

hungpecc1 · 14/12/20

nguyenanhdung8111982 đã viết:
em có đường dẫn nguồn fromPath = "C:\Users\Admin\Desktop\CG\" bao gồm file csv như dưới
20200425_06_002_QGV_GS013858_01_360_updated_0
20200425_06_002_QGV_GS013858_01_updated_0
20200425_06_001_QGV_GS013858_01_updated_0
và đường dẫn đích có 2 folder
toPath = "C:\Users\Admin\Desktop\Test\"
20200425_06_001_QGV_GS013858_01
20200425_06_002_QGV_GS013858_01
Trong trường hợp folder tồn tại thì move file vô ổn.
nhưng khi folder không tồn tại thì em có dùng tạo thư mục và move file vô thì kết quả không đúng
If Len(Dir(toSubPath, vbDirectory)) = 0 Then MkDir toSubPath
đây là đoạn code nhờ anh chị sửa:

Mã:

Option Explicit Sub MoveFiles() Dim fName As String, fromPath As String, toPath As String Dim toSubPath As String, cnt As Long Dim toSubPath1 As String, cnt1 As Long On Error Resume Next 'fromPath = Application.InputBox("Nhap duong dan nguon: ") 'toPath = Application.InputBox("Nhap duong dan dich: ") toPath = "C:\Users\Admin\Desktop\Test\" 'duong dan muon move den fromPath = "C:\Users\Admin\Desktop\CG\" 'duong dan chua file csv fName = Dir(fromPath & "*.csv") Do While Len(fName) > 10 If Right(fName, 14) = "_updated_0.csv" Then cnt = 0 toSubPath = toPath & Left(fName, Len(fName) - 14) & "\" 'If Len(Dir(toSubPath, vbDirectory)) = 0 Then MkDir toSubPath 'If Dir(toSubPath, vbDirectory) = "" Then MkDir toSubPath Name (fromPath & fName) As (toSubPath & fName) End If If Right(fName, 18) = "_360_updated_0.csv" Then cnt = 0 toSubPath = toPath & Left(fName, Len(fName) - 18) & "\" Name (fromPath & fName) As (toSubPath & fName) End If fName = Dir Loop MsgBox "Ho" & ChrW(224) & "n Th" & ChrW(224) & "nh !!!" cnt = cnt + 1 End Sub

trân trọng

Loại bài này nên dùng File system object xử lý

hungpecc1 · 14/12/20

nguyenanhdung8111982 đã viết:
em có đường dẫn nguồn fromPath = "C:\Users\Admin\Desktop\CG\" bao gồm file csv như dưới
20200425_06_002_QGV_GS013858_01_360_updated_0
20200425_06_002_QGV_GS013858_01_updated_0
20200425_06_001_QGV_GS013858_01_updated_0
và đường dẫn đích có 2 folder
toPath = "C:\Users\Admin\Desktop\Test\"
20200425_06_001_QGV_GS013858_01
20200425_06_002_QGV_GS013858_01
Trong trường hợp folder tồn tại thì move file vô ổn.
nhưng khi folder không tồn tại thì em có dùng tạo thư mục và move file vô thì kết quả không đúng
If Len(Dir(toSubPath, vbDirectory)) = 0 Then MkDir toSubPath
đây là đoạn code nhờ anh chị sửa:

Mã:

Option Explicit Sub MoveFiles() Dim fName As String, fromPath As String, toPath As String Dim toSubPath As String, cnt As Long Dim toSubPath1 As String, cnt1 As Long On Error Resume Next 'fromPath = Application.InputBox("Nhap duong dan nguon: ") 'toPath = Application.InputBox("Nhap duong dan dich: ") toPath = "C:\Users\Admin\Desktop\Test\" 'duong dan muon move den fromPath = "C:\Users\Admin\Desktop\CG\" 'duong dan chua file csv fName = Dir(fromPath & "*.csv") Do While Len(fName) > 10 If Right(fName, 14) = "_updated_0.csv" Then cnt = 0 toSubPath = toPath & Left(fName, Len(fName) - 14) & "\" 'If Len(Dir(toSubPath, vbDirectory)) = 0 Then MkDir toSubPath 'If Dir(toSubPath, vbDirectory) = "" Then MkDir toSubPath Name (fromPath & fName) As (toSubPath & fName) End If If Right(fName, 18) = "_360_updated_0.csv" Then cnt = 0 toSubPath = toPath & Left(fName, Len(fName) - 18) & "\" Name (fromPath & fName) As (toSubPath & fName) End If fName = Dir Loop MsgBox "Ho" & ChrW(224) & "n Th" & ChrW(224) & "nh !!!" cnt = cnt + 1 End Sub

trân trọng

Code có dàn ý theo kiểu này :
Sub test()
Dim toPath$, fromPath$, newFolder As Folder
fromPath = "C:\Users\Admin\Desktop\CG\"
toPath = "C:\Users\Admin\Desktop\Test\"
With New FileSystemObject
If .FolderExists(toPath) Then
.CopyFile ................................
Else
Set newFolder = .CreateFolder(toPath)
newFolder.Copy.............................................
End With
End Sub

HeSanbi · 15/12/20

Bạn tham khảo hàm tạo folder:

JavaScript:

' __   _____   _ ®
' \ \ / / _ | / \
'  \ \ /| _ \/ / \
'   \_/ |___/_/ \_\
'
' Last Edit: 20/03/2020 00:26
Function CreateFolder(ByVal FolderPath As String, Optional ByVal FileSystem As Object) As Boolean
  Dim FolderArray, tmp$, i As Integer, UB As Integer, tFolder$
  tFolder = FolderPath
  If VBA.Right(tFolder, 1) = "\" Then tFolder = VBA.Left(tFolder, VBA.Len(tFolder) - 1)
  If tFolder Like "\\*\*" Then tFolder = VBA.Replace(tFolder, "\", "@", 1, 3)
  FolderArray = VBA.Split(tFolder, "\")
  FolderArray(0) = VBA.Replace(FolderArray(0), "@", "\", 1, 3)
  On Error GoTo Ends
  If FileSystem Is Nothing Then
    Set FileSystem = VBA.CreateObject("Scripting.FileSystemObject")
  End If
  UB = UBound(FolderArray)
  With FileSystem
    For i = 0 To UB
      tmp = tmp & FolderArray(i) & "\"
      If Not .FolderExists(tmp) Then .CreateFolder (tmp)
      CreateFolder = (i = UB) And Len(FolderArray(i)) > 0 And FolderArray(i) <> " "
    Next
  End With
Ends:
End Function

nguyenanhdung8111982 · 15/12/20

hungpecc1 đã viết:
Code có dàn ý theo kiểu này :
Sub test()
Dim toPath$, fromPath$, newFolder As Folder
fromPath = "C:\Users\Admin\Desktop\CG\"
toPath = "C:\Users\Admin\Desktop\Test\"
With New FileSystemObject
If .FolderExists(toPath) Then
.CopyFile ................................
Else
Set newFolder = .CreateFolder(toPath)
newFolder.Copy.............................................
End With
End Sub

Cám ơn bạn nhiều nhé!!!

Bài đã được tự động gộp: 15/12/20

Cám ơn bạn nhiều nhé!!!

HeSanbi đã viết:

Bạn tham khảo hàm tạo folder:

JavaScript:

' __   _____   _ ®
' \ \ / / _ | / \
'  \ \ /| _ \/ / \
'   \_/ |___/_/ \_\
'
' Last Edit: 20/03/2020 00:26
Function CreateFolder(ByVal FolderPath As String, Optional ByVal FileSystem As Object) As Boolean
  Dim FolderArray, tmp$, i As Integer, UB As Integer, tFolder$
  tFolder = FolderPath
  If VBA.Right(tFolder, 1) = "\" Then tFolder = VBA.Left(tFolder, VBA.Len(tFolder) - 1)
  If tFolder Like "\\*\*" Then tFolder = VBA.Replace(tFolder, "\", "@", 1, 3)
  FolderArray = VBA.Split(tFolder, "\")
  FolderArray(0) = VBA.Replace(FolderArray(0), "@", "\", 1, 3)
  On Error GoTo Ends
  If FileSystem Is Nothing Then
    Set FileSystem = VBA.CreateObject("Scripting.FileSystemObject")
  End If
  UB = UBound(FolderArray)
  With FileSystem
    For i = 0 To UB
      tmp = tmp & FolderArray(i) & "\"
      If Not .FolderExists(tmp) Then .CreateFolder (tmp)
      CreateFolder = (i = UB) And Len(FolderArray(i)) > 0 And FolderArray(i) <> " "
    Next
  End With
Ends:
End Function

Cám ơn bạn Hesanbi nhiều nhé!!!

Nhờ anh chị giúp sửa code kiểm tra thư mục không tồn tại thì tạo và di chuyển file cùng tên vào (1 người xem)

Người dùng đang xem chủ đề này

nguyenanhdung8111982

Thành viên hoạt động

Maika8008

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

hungpecc1

Thành viên gắn bó

hungpecc1

Thành viên gắn bó

HeSanbi

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨

nguyenanhdung8111982

Thành viên hoạt động

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