如何把包含部分关键词的文件，移入包含相同部分关键词的文件夹内

1sdffg

比如
A目录的文件     
     小明身份证   小红毕业证  小蓝工资表
  B目录的文件夹
     122小明2331233    011小红123123      006小蓝123123
需要 把A目录包含【小明】的文件移入到B目录包含【小明】的文件夹
比如 设置源目录和设置目标目录，填  小明关键词就移入目标内的文件夹
求大佬出手
测试文件下载 测试包.zip (124.45 KB, 下载次数: 5)

2024-8-20 01:06 上传

点击文件名下载附件

ykcbf1100

因为文件名中并不只是有姓名，目标文件夹只含有姓名，简单起见，这里就约定姓名都是3个字。

附件供参考。。。

ykcbf1100

文件移动。。。

1. Sub ykcbf()   '//2024.8.20
   
2.     Application.ScreenUpdating = False
   
3.     Set fso = CreateObject("Scripting.FileSystemObject")
   
4.     p = ThisWorkbook.Path & ""
   
5.     p1 = p & "1移动文件"
   
6.     p2 = p & "2目的地"
   
7.     For Each f In fso.GetFolder(p1).Files
   
8.         fn = fso.GetBaseName(f)
   
9.         xm = Left(fn, 3)
   
10.         For Each fd In fso.GetFolder(p2).SubFolders
    
11.             If InStr(fd.Name, xm) Then
    
12.                 fso.MoveFile f, fd.Path & ""
    
13.             End If
    
14.         Next
    
15.     Next f
    
16.     Application.ScreenUpdating = True
    
17.     MsgBox "OK！"
    
18. End Sub
    
19. 
    

复制代码

liulang0808

Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    Set fso = CreateObject("scripting.filesystemobject")
    With CreateObject("vbscript.regexp")
        .Pattern = "[一-龥]+"
        For Each fd In fso.getfolder(ThisWorkbook.Path & "\2目的地\").subfolders
            If .test(fd.Name) Then
                d(.Execute(fd.Name)(0) & "") = fd & "\"
            End If
        Next fd
        .Pattern = Join(d.keys, "|")
        For Each f In fso.getfolder(ThisWorkbook.Path & "\1移动文件\").Files
            If .test(f.Name) Then
                k = .Execute(f.Name)(0) & ""
                If d.exists(k) Then
                    fso.movefile f, d(k)
                End If
            End If
        Next f
    End With
End Sub

liulang0808

模拟供参考。。。。。。

ykcbf1100

为了让结果更准确，加入正则，不必再去管姓名有几个字了。

ykcbf1100

修正一下。。。

1. Sub ykcbf()   '//2024.8.20
   
2.     Application.ScreenUpdating = False
   
3.     Set fso = CreateObject("Scripting.FileSystemObject")
   
4.     Set reg = CreateObject("VBScript.Regexp")
   
5.     With reg
   
6.         .pattern = "[^一-龢]+"
   
7.         .Global = True
   
8.         .IgnoreCase = True
   
9.     End With
   
10.     p = ThisWorkbook.Path & ""
    
11.     p1 = p & "1移动文件"
    
12.     p2 = p & "2目的地"
    
13.     For Each f In fso.GetFolder(p1).Files
    
14.         fn = fso.GetBaseName(f)
    
15.         For Each fd In fso.GetFolder(p2).SubFolders
    
16.             fdd = reg.Replace(fd.Name, "")
    
17.             If InStr(fn, fdd) Then
    
18.                 fso.MoveFile f, fd.Path & ""
    
19.             End If
    
20.         Next
    
21.     Next f
    
22.     Application.ScreenUpdating = True
    
23.     MsgBox "OK！"
    
24. End Sub
    

复制代码

limonet

关键字：-match %

limonet

Sub limonet()
    CreateObject("wscript.shell").Run "powershell push-location " & ThisWorkbook.Path _
    & ";dir .\1移动文件 | %{foreach ($i in (dir .\2目的地))" _
    & "{if($_ -match ($i -replace '\d','')){move $_.fullname $i.fullname}}}", 0
End Sub

1sdffg

limonet 发表于 2024-8-20 09:00
关键字：-match %

学到了，‌MATCH函数的用法