将指定文件夹剪切到目标文件夹中

廪囧

关于将单元格包含指定字符的文件夹全部剪切到指定的目标文件夹中，比较复杂，为了归档用的，请老师帮忙，见 附件。
   如果原文件有重名则可以提醒。
   如果目标文件夹没有，则可以新建。

liulang0808

http://club.excelhome.net/thread-1258425-1-1.html
文件及文件夹操作汇总

廪囧

试了，不完全适用，而且移动文件出现错误，请老师帮忙看看附件的例子，谢谢！

廪囧

顶起，请老师帮忙，谢谢！

zhaogang1960

请参考：
Sub Macro1()
    Dim Fso As Object, p$, p2$, arr, i&
    p = [a2] '源文件夹，需要手工填写
    p2 = [b2] '目标文件夹，需要手工填写
    If Dir(p2, vbDirectory) = "" Then MkDir p2
    Set Fso = CreateObject("scripting.filesystemobject")
    arr = Range("A1:A" & Range("A65536").End(xlUp).Row)
    On Error Resume Next
    For i = 4 To UBound(arr)
        Fso.MoveFolder p & "*" & arr(i, 1) & "*", p2
    Next
    MsgBox "ok"
End Sub

zhaogang1960

选择源文件夹和目标文件夹：
Sub Macro2()
    Dim Fso As Object, p$, p2$, arr, i&
    With Application.FileDialog(msoFileDialogFolderPicker) '选择源文件夹
        .Title = "请选择源文件夹"
        If .Show = False Then Exit Sub
        p = .SelectedItems(1) & "\"
        [a2] = p
    End With
    With Application.FileDialog(msoFileDialogFolderPicker) '选择目标文件夹
        .Title = "请选择目标文件夹"
        If .Show = False Then Exit Sub
        p2 = .SelectedItems(1) & "\"
        [b2] = p2
    End With
    Set Fso = CreateObject("scripting.filesystemobject")
    arr = Range("A1:A" & Range("A65536").End(xlUp).Row)
    On Error Resume Next
    For i = 4 To UBound(arr)
        Fso.MoveFolder p & "*" & arr(i, 1) & "*", p2
    Next
    MsgBox "ok"
End Sub

zhaogang1960

请测试附件
复制文件夹工具 v1.rar (11.67 KB, 下载次数: 88)

2016-4-15 10:24 上传

点击文件名下载附件

廪囧

zhaogang1960 发表于 2016-4-15 10:24
请测试附件

老师，文件不归档呢？

zhaogang1960

廪囧 发表于 2016-4-15 15:28
老师，文件不归档呢？

归档是什么意思？是将移动的文件夹名一一写到C列？C列原来数据怎么处理？

zhaogang1960

Sub Macro1()
    Dim Fso As Object, SubFolder As Object, p$, p2$, s$, smeg$, arr, brr(), i&, m&, d As Object
    Set d = CreateObject("scripting.dictionary")
    p = [a2] '源文件夹，需要手工填写
    p2 = [b2] '目标文件夹，需要手工填写
    If Dir(p2, vbDirectory) = "" Then MkDir p2
    Set Fso = CreateObject("scripting.filesystemobject")
    arr = Range("A1:A" & Range("A65536").End(xlUp).Row)
    For Each SubFolder In Fso.GetFolder(p2).SubFolders
        d(SubFolder.Name) = ""
    Next
    ReDim brr(1 To Fso.GetFolder(p).SubFolders.Count, 1 To 1)
    For Each SubFolder In Fso.GetFolder(p).SubFolders
        For i = 4 To UBound(arr)
            If InStr(SubFolder.Name, arr(i, 1)) Then
                If Not d.Exists(SubFolder.Name) Then
                    SubFolder.Move p2
                    d(SubFolder.Name) = ""
                    m = m + 1
                    brr(m, 1) = SubFolder.Name
                Else
                    s = s & vbCrLf & SubFolder.Name
                End If
            End If
        Next
    Next
    Range("C4:C65536").ClearContents
    If m > 0 Then
        Range("C4").Resize(m) = brr '移动的文件夹名写到C列
        smeg = "共移动文件夹：" & vbCrLf & m & "个。"
    End If
    If Len(s) Then smeg = smeg & vbCrLf & "文件夹中有重名：" & s
    If Len(smeg) Then
        MsgBox smeg, vbInformation
    Else
        MsgBox "没有发现符合条件的文件夹。", vbInformation
    End If
    Set Fso = Nothing
End Sub