按文件名中的关键字分检到指定文件夹

河洛张红峰

求助说明

1，新建一个“附件2汇总”文件夹

2，把“单位1上报”、“单位2上报”、“单位3上报”三文件夹中的带有“附件2”关键字的文件复制到“附件2汇总”文件夹（参看“附件1汇总”文件）

3，如果上报文件夹里没有附件2文件，则在“记录.xlsm”工作表中记录出来

3190496160

Sub 文件分拣()
Dim arr()
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.getfolder(ThisWorkbook.Path)
For Each fd In f.subfolders
    If InStr(fd.Name, "汇总") = 0 Then
        n = n + 1
        ReDim Preserve arr(1 To n)
        arr(n) = fd.Name
    End If
Next
Dim br()
ReDim br(1 To n, 1 To 1)
wjj = ThisWorkbook.Path & "\附件2汇总"
If fs.folderexists(wjj) Then fs.deletefolder wjj
fs.CreateFolder wjj
For i = 1 To n
    m = 0
    f = Dir(ThisWorkbook.Path & "\" & arr(i) & "\*.xls*")
    Do While f <> ""
        If InStr(f, "附件2") > 0 Then
            fs.Copyfile ThisWorkbook.Path & "\" & arr(i) & "\" & f, ThisWorkbook.Path & "\附件2汇总\"
            m = m + 1
        End If
    f = Dir
    Loop
    Set f = Nothing
    If m = 0 Then
        k = k + 1
        br(k, 1) = arr(i) & "文件夹中没有附件2"
    End If
Next i
Set fs = Nothing
With Sheet1
    .[a1:a1000] = Empty
    If k <> "" Then .[a1].Resize(k, 1) = br
End With
MsgBox "ok!"
End Sub

3190496160

（求助）文件按关键字分检.rar (103.84 KB, 下载次数: 12)

2024-4-21 08:53 上传

点击文件名下载附件

河洛张红峰

3190496160 发表于 2024-4-21 08:53

谢谢大神的帮助，你真太厉害了！

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.21
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     p = ThisWorkbook.Path & ""
   
6.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
7.     sh.UsedRange.Offset(1) = ""
   
8.     fns = [{"单位1上报","单位2上报","单位3上报"}]
   
9.     p1 = p & "附件2汇总"
   
10.     st = "附件2"
    
11.     If Not fso.FolderExists(p1) Then fso.CreateFolder p1
    
12.     n = 1
    
13.     For x = 1 To UBound(fns)
    
14.         p2 = p & fns(x) & ""
    
15.         m = 0
    
16.         For Each f In fso.GetFolder(p2).Files
    
17.             If f.Name Like "*.xls*" Then
    
18.                 fn = fso.GetBaseName(f)
    
19.                 If InStr(fn, st) Then
    
20.                     m = m + 1
    
21.                     fso.CopyFile f, p1
    
22.                 End If
    
23.             End If
    
24.         Next f
    
25.         If m = 0 Then
    
26.             n = n + 1
    
27.             sh.Cells(n, 1) = fns(x) & "文件夹中没有" & st
    
28.         End If
    
29.     Next
    
30.     MsgBox "OK！"
    
31. End Sub
    
32. 
    

复制代码

河洛张红峰

ykcbf1100 发表于 2024-4-21 09:14
附件供参考。。。

非常感谢大神的帮助，您的帮助是了继续学习的动力！

lizhipei78

文件分拣不求人
https://club.excelhome.net/threa ... tml?_dsign=c9b56772

河洛张红峰

lizhipei78 发表于 2024-4-21 09:31
文件分拣不求人
https://club.excelhome.net/thread-1681213-1-1.html?_dsign=c9b56772

谢谢，还有这么好的工具，真是感谢

quqiyuan

参与一下