[已解决]移动指定文件

舒云天

移动指定文件，运行出错，帮忙 看看。谢谢

最佳答案

月排行榜 / 总排行榜

爱疯

2016-5-5 19:46

舒云天 发表于 2016-5-5 19:35
出现错误如截图

Sub moveFiles()
    Dim fso, A, i%, p$, desP$, desF$, msg$
    Set fso = CreateObject("Scripting.FileSystemObject")
    p = ThisWorkbook.Path & "\"
    A = Sheets(1).Range("a1").CurrentRegion

    For i = 1 To UBound(A)
        desF = p & A(i, 1) & ".doc"
        desP = p & A(i, 2) & "\"
        If fso.FolderExists(desP) = False Then fso.CreateFolder (desP)
        If fso.FileExists(desF) = False Then msg = msg & "," & A(i, 1) Else fso.moveFile desF, desP
    Next i
    MsgBox Mid(msg, 2), , "无效文件清单"
End Sub

3.rar (40.2 KB, 下载次数: 10)

2016-5-5 19:45 上传

点击文件名下载附件

跳转到最佳答案楼层

爱疯

Sub MoveFiles()
'
' MoveFiles Macro
'
'
    Dim i As Integer
    Dim s As String
    Dim FilPath As String
    Dim aaa As String
    Dim bbb As String
    Dim MyFile As Object
    With Sheet1

        For i = 1 To .Range("a65536").End(xlUp).Row
            FilPath = ThisWorkbook.Path & "\" & .Cells(i, 1).Text & ".doc"
            aaa = ThisWorkbook.Path & "\" & Sheet1.Range("b" & i).Value & "\" & .Cells(i, 1).Text & ".doc"""
            bbb = ThisWorkbook.Path & "\" & Sheet1.Range("b" & i).Value & "\"
            If Dir(bbb, vbDirectory) <> "" Then
                If Dir(FilPath) <> "" Then
                    Set MyFile = CreateObject("Scripting.FileSystemObject")
                    MyFile.MoveFile FilPath, bbb
                    Set MyFile = Nothing
                Else
                    s = s & Chr(10) & .Cells(i, 1).Text
                End If
            Else
                MkDir (bbb)
                Set MyFile = CreateObject("Scripting.FileSystemObject")
                MyFile.MoveFile FilPath, bbb
                Set MyFile = Nothing
            End If
        Next

    End With
    If s <> "" Then
        MsgBox s & Chr(10) & "无以上文件!"
    End If
End Sub




红色是修改过的地方

爱疯

Sub moveFiles()
    Dim fso, A, i%, p$, desP$, desF$

    Set fso = CreateObject("Scripting.FileSystemObject")
    p = ThisWorkbook.p & "\"
    A = Sheets(1).Range("a1").CurrentRegion

    For i = 1 To UBound(A)
        desF = p & A(i, 1) & ".doc"
        desP = p & A(i, 2) & "\"
        If fso.FolderExists(desP) = False Then fso.CreateFolder (desP)
        If fso.FileExists(desF) = False Then msg = msg & "," & A(i, 1) Else fso.moveFile desF, desP
    Next i
    MsgBox Mid(msg, 2), , "无效文件清单"
End Sub

2.rar (41.31 KB, 下载次数: 6)

2016-5-5 17:29 上传

点击文件名下载附件

舒云天

爱疯 发表于 2016-5-5 17:29
Sub moveFiles()
    Dim fso, A, i%, p$, desP$, desF$

出现错误如截图

爱疯

舒云天 发表于 2016-5-5 19:35
出现错误如截图

Sub moveFiles()
    Dim fso, A, i%, p$, desP$, desF$, msg$
    Set fso = CreateObject("Scripting.FileSystemObject")
    p = ThisWorkbook.Path & "\"
    A = Sheets(1).Range("a1").CurrentRegion

    For i = 1 To UBound(A)
        desF = p & A(i, 1) & ".doc"
        desP = p & A(i, 2) & "\"
        If fso.FolderExists(desP) = False Then fso.CreateFolder (desP)
        If fso.FileExists(desF) = False Then msg = msg & "," & A(i, 1) Else fso.moveFile desF, desP
    Next i
    MsgBox Mid(msg, 2), , "无效文件清单"
End Sub

3.rar (40.2 KB, 下载次数: 10)

2016-5-5 19:45 上传

点击文件名下载附件

舒云天

非常感谢你。另外，如果是已经有文件夹存在，并且已命名a和b  ad,要怎样修改VBA呢？

舒云天

舒云天 发表于 2016-5-5 19:49
非常感谢你。另外，如果是已经有文件夹存在，并且已命名a和b  ad,要怎样修改VBA呢？

谢谢你 ，经测试，很好用。无论文件夹是否存在都行。

舒云天

爱疯 发表于 2016-5-5 19:46
Sub moveFiles()
    Dim fso, A, i%, p$, desP$, desF$, msg$
    Set fso = CreateObject("Scripting ...

多重移动

爱疯

Sub moveFiles()
    Dim fso, A, i%, j%, p$, desP$, desF$, msg$
    Set fso = CreateObject("Scripting.FileSystemObject")
    p = ThisWorkbook.Path & "\"
    A = Sheets(1).Range("a1").CurrentRegion

    For i = 1 To UBound(A)
        '1）逐层创建文件夹
        desP = p
        For j = 2 To UBound(A, 2)
            desP = desP & A(i, j) & "\"
            If fso.FolderExists(desP) = False Then fso.CreateFolder desP
        Next j

        '2）移动文件
        desF = p & A(i, 1) & ".doc"
        If fso.FileExists(desF) Then fso.moveFile desF, desP Else msg = msg & "," & A(i, 1)
    Next i

    MsgBox Mid(msg, 2), , "无效文件清单"
End Sub

4.rar (40.69 KB, 下载次数: 3)

2016-5-13 10:50 上传

点击文件名下载附件

舒云天

万分感谢。大大节省了工作时间。