按PDF文件名称分类到对应文件夹

duquancai

川黔1985 发表于 2017-11-28 21:40
把pdf文件移动到对应的文件夹里面，文件夹也需要根据不带序号的pdf文件脚本来建立

并不复杂，按部就班写就行了。需要建立多少个文件，经过遍历，用字典归类就知道了。

小川1985

huang1314wei 发表于 2017-11-28 21:44

老师，我给的文件只是5000多个文件中的一部分，名称也不只这三种，有很多种文件名，比如铁路良好，村道完好，村道完好01等，但是命名规则都是:中文名+序号。

小川1985

huang1314wei 发表于 2017-11-28 21:44

老师，我给的文件只是5000多个文件中的一部分，名称也不只这三种，有很多种文件名，比如铁路良好，村道完好，村道完好01等，但是命名规则都是:中文名+序号。

huang1314wei

小川1985 发表于 2017-11-28 22:13
老师，我给的文件只是5000多个文件中的一部分，名称也不只这三种，有很多种文件名，比如铁路良好，村道完 ...

1. '提问的时候，尽量一次性把问题说清楚，不要模棱两可的，耽误的是时间
   
2. '附件就不传了，把这个代码复制到之前的文件里面即可
   
3. Sub test()
   
4.     Dim MyPath$, myFile$, d, strName$
   
5.     Dim oRegExp As Object
   
6.     Set oRegExp = CreateObject("vbscript.regexp")
   
7.     With oRegExp
   
8.         .Global = True
   
9.         .Pattern = "\d+"
   
10.     End With
    
11.     Set d = CreateObject("scripting.dictionary")
    
12.     MyPath = ThisWorkbook.Path & "\"
    
13.     On Error Resume Next
    
14.     myFile = Dir(MyPath & "*.pdf")
    
15.     Do While myFile <> ""
    
16.         strName = Split(myFile, ".")(0)
    
17.         strName = oRegExp.Replace(strName, "")
    
18.         If Not d.exists(strName) Then
    
19.             d(strName) = ""
    
20.             MkDir MyPath & strName
    
21.         End If
    
22.         Name MyPath & myFile As MyPath & strName & "\" & myFile
    
23.         myFile = Dir
    
24.     Loop
    
25.     MsgBox "OK"
    
26. End Sub

复制代码

huang1314wei

附件参考--修改2.rar (26.4 KB, 下载次数: 66)

2017-11-28 22:32 上传

点击文件名下载附件

川黔1985

huang1314wei 发表于 2017-11-28 22:32

完美解决 谢谢老师出手  问题没写清除耽误您时间了

闻启学

我来一个FSO

1. Sub 按钮1_Click()
   
2.     Application.ScreenUpdating = False
   
3.     Set fso = CreateObject("scripting.filesystemobject")
   
4.     Set ff = fso.getfolder("D:\360安全浏览器下载\归档\归档") 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改
   
5.     ActiveSheet.UsedRange.ClearContents
   
6.     Dim newfoder As String
   
7.     a = 1
   
8.     For Each f In ff.File
   
9.      newfoder = RegString(CStr(Split(f.Name, ".")(0))) '//获得文件名称作为文件夹名称
   
10.      
    
11.      If Not fso.folderexists(newfoder) Then '如果不存在 则创建文件夹
    
12.      fso.CreateFolder ("D:\360安全浏览器下载\归档" & newfoder)
    
13.      End If
    
14.      
    
15.      '// 复制对应的文件到相应的文件夹出
    
16.      
    
17.        fso.copyfile f, "D:\360安全浏览器下载\归档" & newfoder & "" & f.Name
    
18.       
    
19.     Next f
    
20.     Application.ScreenUpdating = True
    
21. End Sub

复制代码

我

闻启学

楼上用字典来 我来一个 FSO

1. Sub 按钮1_Click()
   
2.     Application.ScreenUpdating = False
   
3.     Set fso = CreateObject("scripting.filesystemobject")
   
4.     Set ff = fso.getfolder("D:\360安全浏览器下载\归档\归档") 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改
   
5.     ActiveSheet.UsedRange.ClearContents
   
6.     Dim newfoder As String
   
7.     a = 1
   
8.     For Each f In ff.File
   
9.      newfoder = RegString(CStr(Split(f.Name, ".")(0))) '//获得文件名称作为文件夹名称
   
10.      
    
11.      If Not fso.folderexists(newfoder) Then '如果不存在 则创建文件夹
    
12.      fso.CreateFolder ("D:\360安全浏览器下载\归档" & newfoder)
    
13.      End If
    
14.      
    
15.      '// 复制对应的文件到相应的文件夹出
    
16.      
    
17.        fso.copyfile f, "D:\360安全浏览器下载\归档" & newfoder & "" & f.Name
    
18.       
    
19.     Next f
    
20.     Application.ScreenUpdating = True
    
21. End Sub

复制代码

duquancai

Sub pdf文件_分类归档()
    Dim pa$, reg As Object, d As Object, sr$, k, t, fol As Object
    Dim f As Object, fd As Object, fso As Object
    Set fol = CreateObject("Shell.Application").BrowseForFolder(0, "GetFolder", 0)
    If Not fol Is Nothing Then pa = fol.Items.Item.Path Else MsgBox "请选目标文件夹": Exit Sub
    If Right(pa, 1) <> "\" Then pa = pa & "\"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set d = CreateObject("Scripting.Dictionary")
    Set reg = CreateObject("VBScript.Regexp")
    reg.Pattern = "^((?:(?!(?:\d+)?\.pdf).)+)"
    For Each f In fso.GetFolder(pa).Files
        If f.Name Like "*.pdf" Then
            If Not InStr(f.Name, "~$") Then
                sr = reg.Execute(f.Name)(0).submatches(0)
                d(sr) = d(sr) & "|" & pa & f.Name
            End If
        End If
    Next
    k = d.Keys: t = d.Items
    For i = 0 To d.Count - 1
        If Not fso.FolderExists(pa & k(i)) Then
            fso.CreateFolder pa & k(i)
            fn = Split(Mid(t(i), 2), "|")
            For j = 0 To UBound(fn)
                ff = Mid(fn(j), InStrRev(fn(j), "\") + 1)
                If Not fso.FileExists(pa & k(i) & "\" & ff) Then
                    fso.MoveFile fn(j), pa & k(i) & "\" & ff
                End If
            Next
        Else
            fn = Split(Mid(t(i), 2), "|")
            For j = 0 To UBound(fn)
                ff = Mid(fn(j), InStrRev(fn(j), "\") + 1)
                If Not fso.FileExists(pa & k(i) & "\" & ff) Then
                    fso.MoveFile fn(j), pa & k(i) & "\" & ff
                End If
            Next
        End If
    Next
    MsgBox "ok!"
End Sub

duquancai

川黔1985 发表于 2017-11-28 22:37
完美解决 谢谢老师出手  问题没写清除耽误您时间了

第1个文件.pdf
第1个文件01.pdf
第1个文件02.pdf
第2个文件.pdf
第2个文件01.pdf
第2个文件02.pdf
第2个文件03.pdf
这样的文件，完美不？？？哈哈哈