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

Quảng cáo

nguyenanhdung8111982

Thành viên chính thức
Tham gia ngày
1 Tháng mười một 2019
Bài viết
53
Được thích
3
Điểm
108
Tuổi
38
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

Thành viên tích cực
Tham gia ngày
12 Tháng sáu 2020
Bài viết
1,020
Được thích
819
Điểm
368
Bạn thử chạy step by step xem chỗ nào chạy không đúng!
 

hungpecc1

Thành viên gắn bó
Tham gia ngày
24 Tháng tám 2012
Bài viết
1,668
Được thích
2,262
Điểm
1,368
Tuổi
34
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

Thành viên gắn bó
Tham gia ngày
24 Tháng tám 2012
Bài viết
1,668
Được thích
2,262
Điểm
1,368
Tuổi
34
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

Thành viên gắn bó
Tham gia ngày
24 Tháng hai 2013
Bài viết
1,624
Được thích
1,885
Điểm
868
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

Thành viên chính thức
Tham gia ngày
1 Tháng mười một 2019
Bài viết
53
Được thích
3
Điểm
108
Tuổi
38
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é!!!
 
Quảng cáo
Top Bottom