[已解决]如何用宏进行文档归类

sx001

如何用宏进行文档归类,凡是含关键字前期的放入前期文件夹
                    凡是含关键字中期的放入中期文件夹
                    凡是含关键字后期的放入后期文件夹
                    凡是含关键字地市的放入地市文件夹
详见附件,谢谢!

Z6hmF1hR.rar (21.89 KB, 下载次数: 24)

2009-12-8 16:19 上传

点击文件名下载附件
如何用宏进行文档归类

最佳答案

月排行榜 / 总排行榜

爱疯

2009-12-8 19:42

Sub aaa()
    Dim objshell As Object, objfolder As Object
    Dim myPath$, myFile$, SourceFile$, DestinationFile$
    Dim i As Byte
    Dim arr

    '得到合并路径
    Set objshell = CreateObject("Shell.Application")
    Set objfolder = objshell.BrowseForFolder(0, "选择文件夹", 0, 0)
    If objfolder Is Nothing Then
        End
    Else
        myPath = objfolder.self.Path & "\"
    End If
    Set objfolder = Nothing
    Set objshell = Nothing
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    arr = [{"前期","中期","后期","地市"}]
   
    '循环所有工作簿
    myFile = Dir(myPath & "*.doc")
    Do While myFile <> ""
        For i = 1 To UBound(arr)
            If myFile Like "*" & arr(i) & "*" Then
                '移动文件
                SourceFile = myPath & myFile
                DestinationFile = myPath & arr(i) & "\" & myFile
                FileCopy SourceFile, DestinationFile
                Kill myPath & myFile
                Exit For
            End If
        Next i
        myFile = Dir
    Loop
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "完成"
End Sub

跳转到最佳答案楼层

sx001

按文档名进行文档归类

爱疯

Sub aaa()
    Dim objshell As Object, objfolder As Object
    Dim myPath$, myFile$, SourceFile$, DestinationFile$
    Dim i As Byte
    Dim arr

    '得到合并路径
    Set objshell = CreateObject("Shell.Application")
    Set objfolder = objshell.BrowseForFolder(0, "选择文件夹", 0, 0)
    If objfolder Is Nothing Then
        End
    Else
        myPath = objfolder.self.Path & "\"
    End If
    Set objfolder = Nothing
    Set objshell = Nothing
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    arr = [{"前期","中期","后期","地市"}]
   
    '循环所有工作簿
    myFile = Dir(myPath & "*.doc")
    Do While myFile <> ""
        For i = 1 To UBound(arr)
            If myFile Like "*" & arr(i) & "*" Then
                '移动文件
                SourceFile = myPath & myFile
                DestinationFile = myPath & arr(i) & "\" & myFile
                FileCopy SourceFile, DestinationFile
                Kill myPath & myFile
                Exit For
            End If
        Next i
        myFile = Dir
    Loop
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "完成"
End Sub

sx001

爱疯老师,先谢谢你,我再试.

爱疯

不用谢，我们都是来学习的。

其实，我这是大拼版（注释都忘删了）

[em04]

sx001

好快速啊,最佳答案也,谢谢爱疯老师