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

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ó đườ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
 
Bạn thử chạy step by step xem chỗ nào chạy không đúng!
 
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ý
 
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
 
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
 
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:

Cám ơn bạn nhiều nhé!!!
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é!!!
 
Web KT
Back
Top Bottom