Giúp em di chuyển folder bằng VBA (1 người xem)

[hitoko]

Bên em có khá nhiều folder dữ liệu có dạng :
banh khach 1 01-01-16
keo khach 2 01-01-16
banh khach 3 02-01-16
keo khach 4 02-01-16
.....
Bây giờ em muốn Di chuyển tất cả các folder mà có 01-01-16 vào folder tên 01-01-16 ... 02-01-16 vào 02-01-16 ....!
Loay hoay mãi mà ko dc!
Dạng như e lấy *= left(tên folder ,8 ký tự cuối)
sau đó move tất cả các folder có 8 ký tự cuối = * vào đường đẫn D:\giday\* tương ứng ...
Mong các bác trợ giúp ạ!

 

[anhdepjai]

Ngày trước, mình cũng có 1 cái tương tự, được bác siwtom giúp, giờ bạn thử modify theo hướng của mình xem có ổn không nhé

 

[hitoko]

Ngày trước, mình cũng có 1 cái tương tự, được bác siwtom giúp, giờ bạn thử modify theo hướng của mình xem có ổn không nhé

Đangxem....thanKdachiase(kocachdc...kobitvisao)

 

[hitoko]

mong cao nhân giúp .... loay hoay cả đêm hem dc!

 

[Gió Đông]

mong cao nhân giúp .... loay hoay cả đêm hem dc!

File trên của anhdepjai sao rùi??? bạn không phản hồi lại để cùng xét

 

[hitoko]

Em đọc rồi nhưng khi thêm tào lao vào không được .. chắc là vì kiến thức VBA còn quá ít ....Mong các bác giúp!

 

[quanluu]

Em đọc rồi nhưng khi thêm tào lao vào không được .. chắc là vì kiến thức VBA còn quá ít ....Mong các bác giúp!

View attachment 171940

Thế thì bạn thử file này coi. Chắc cái này bạn xài được luôn.

 

[hitoko]

Thế thì bạn thử file này coi. Chắc cái này bạn xài được luôn.

thank bạn nhé .... code dễ hiễu ... để mình cố thêm 1 ít có j mong bạn giúp đỡ!

 

[hitoko]

Sub GPE()
Dim sourceDir As String, destDir As String, subfolder
On Error Resume Next
    Set fso = CreateObject("Scripting.FileSystemObject")
    With fso
        For Each subfolder In .GetFolder(Range("B1")).SubFolders
            sourceDir = subfolder.Path
            destDir = Range("B2").Value & "\" & Right(subfolder.Name, 8)
            If Not .FolderExists(destDir) Then .CreateFolder destDir
            destDir = Range("B2").Value & "\" & Right(subfolder.Name, 8) & "\" & subfolder.Name
            If Not .FolderExists(destDir) Then .CreateFolder destDir
            .CopyFolder sourceDir, destDir
        Next
    End With
    MsgBox ("Done")
End Sub

Code ok luôn .... nhưng làm sao để nó Cut luôn subfolder nhỉ .... em thay đổi chổ ".CopyFolder sourceDir, destDir" mà hem thấy j ...! Mong bác giúp em!

 

[quanluu]

Sub GPE()
Dim sourceDir As String, destDir As String, subfolder
On Error Resume Next
    Set fso = CreateObject("Scripting.FileSystemObject")
    With fso
        For Each subfolder In .GetFolder(Range("B1")).SubFolders
            sourceDir = subfolder.Path
            destDir = Range("B2").Value & "\" & Right(subfolder.Name, 8)
            If Not .FolderExists(destDir) Then .CreateFolder destDir
            destDir = Range("B2").Value & "\" & Right(subfolder.Name, 8) & "\" & subfolder.Name
            If Not .FolderExists(destDir) Then .CreateFolder destDir
            .CopyFolder sourceDir, destDir
        Next
    End With
    MsgBox ("Done")
End Sub

Code ok luôn .... nhưng làm sao để nó Cut luôn subfolder nhỉ .... em thay đổi chổ ".CopyFolder sourceDir, destDir" mà hem thấy j ...! Mong bác giúp em!

Không hiểu ý bạn là như thế nào?

 

[hitoko]

Không hiểu ý bạn là như thế nào?

y em la .... move luon !sau khi move xong folder source se ko con j het!

 

[quanluu]

y em la .... move luon !sau khi move xong folder source se ko con j het!

Thế thì copy xong rùi xóa luôn folder gốc luôn.

Sub GPE()
Dim sourceDir As String, destDir As String, subfolder
On Error Resume Next
    Set fso = CreateObject("Scripting.FileSystemObject")
    With fso
        For Each subfolder In .GetFolder(Range("B1")).SubFolders
            sourceDir = subfolder.Path
            destDir = Range("B2").Value & "\" & Right(subfolder.Name, 8)
            If Not .FolderExists(destDir) Then .CreateFolder destDir
            destDir = Range("B2").Value & "\" & Right(subfolder.Name, 8) & "\" & subfolder.Name
            If Not .FolderExists(destDir) Then .CreateFolder destDir
            .CopyFolder sourceDir, destDir       
        Next
        .DeleteFolder (Range("B1"))
    End With
    MsgBox ("Done")
End Sub

 

[hitoko]

Thế thì copy xong rùi xóa luôn folder gốc luôn.

Sub GPE()
Dim sourceDir As String, destDir As String, subfolder
On Error Resume Next
    Set fso = CreateObject("Scripting.FileSystemObject")
    With fso
        For Each subfolder In .GetFolder(Range("B1")).SubFolders
            sourceDir = subfolder.Path
            destDir = Range("B2").Value & "\" & Right(subfolder.Name, 8)
            If Not .FolderExists(destDir) Then .CreateFolder destDir
            destDir = Range("B2").Value & "\" & Right(subfolder.Name, 8) & "\" & subfolder.Name
            If Not .FolderExists(destDir) Then .CreateFolder destDir
            .CopyFolder sourceDir, destDir       
        Next
        .DeleteFolder (Range("B1"))
    End With
    MsgBox ("Done")
End Sub

Ô .... vậy cứ loay hoay sửa .CopyFolder sourceDir, destDir thanh` .MoveFolder sourceDir, destDir ! gà vãi chường ... mà lỡ trong lúc move bị lỗi nó chạy tới NExt xóa hết Folder source thì sao nhỉ ? có nên để trc lệnh Next ko ạ?
Thank bạn đỡ giúp đỡ

 

[quanluu]

Ô .... vậy cứ loay hoay sửa .CopyFolder sourceDir, destDir thanh` .MoveFolder sourceDir, destDir ! gà vãi chường ... mà lỡ trong lúc move bị lỗi nó chạy tới NExt xóa hết Folder source thì sao nhỉ ? có nên để trc lệnh Next ko ạ?
Thank bạn đỡ giúp đỡ

Sub GPE()
Dim sourceDir As String, destDir As String, subfolder
[COLOR=#ff0000]On Error Goto 1[/COLOR]
    Set fso = CreateObject("Scripting.FileSystemObject")
    With fso
        For Each subfolder In .GetFolder(Range("B1")).SubFolders
            sourceDir = subfolder.Path
            destDir = Range("B2").Value & "\" & Right(subfolder.Name, 8)
            If Not .FolderExists(destDir) Then .CreateFolder destDir
            destDir = Range("B2").Value & "\" & Right(subfolder.Name, 8) & "\" & subfolder.Name
            If Not .FolderExists(destDir) Then .CreateFolder destDir
            .CopyFolder sourceDir, destDir       
        Next
        .DeleteFolder (Range("B1"))
    End With
    MsgBox ("Done")
[COLOR=#ff0000]1:[/COLOR]
End Sub

 

[hitoko]

thank bạn @quanluu1989 nhìu nhìu !!!.... end topic!