按规则创建文件夹，把文件放入对应的文件夹

rendiule01

各位老师，求助VBA

D盘图片 文件夹内有很多格式(jpg,png,bmp,gif,jepg)的图片
100101-1.jpg
100101-2.jpg
100102-1.png
100102-2.png
100103-1.bmp
100103-2.bmp
100104-1.jpg
100104-2.jpg

怎样把图片放在字典里
字典希望是如下
  key            Item
100101      D盘图片/100101-1.jpg
100102      D盘图片/100102-1.png
100103      D盘图片/100103-1.bmp
100104      D盘图片/100104-1.jpg

1.能否按每个图片名称-前面数字，创建去重的文件夹，文件名如100101、100102、100103、100104
2.且把图片放入对应的文件夹内
如100101的文件夹放入的图片：100101-1.jpg，100101-2.jpg；
  100102的文件夹放入的图片：100102-1.png，100102-2.png；
  100103的文件夹放入的图片：100103-1.bmp，100103-2.bmp；
证件原始图片.zip (1.14 MB, 下载次数: 4)

2023-5-8 09:44 上传

点击文件名下载附件

liulang0808

https://club.excelhome.net/threa ... tml?_dsign=73cffde5
资料，楼主可以参考下

ykcbf1100

没有附件，求助效果估计不理想。

limonet

关键字：test-path -eq $false

limonet

Sub limonet()
    CreateObject("wscript.shell").Run "powershell push-location " & ThisWorkbook.Path _
    & "\证件原始图片 -passthru | dir | foreach {'begin'} { if ((test-path ($_ -replace '-.*','')) -eq $False) {md ($_ -replace '-.*','')}} {move $_ ($_ -replace '-.*','') } {'end'}", 0
End Sub

usedrange

1. Sub t()
   
2.     Dim fso, fo, fs, mypath$, f, dic, fon, bl As Boolean
   
3.     mypath = "E:\VBA\证件原始图片"      '这个路径要修改成自己存放文件的路径
   
4.     Set fso = CreateObject("scripting.FileSystemObject")
   
5.     Set fs = fso.getfolder(mypath).Files
   
6.    
   
7.     For Each f In fs
   
8.         fon = Split(f.Name, "-")(0)   '目录名
   
9.         bl = fso.folderExists(mypath & "" & fon)
   
10.         If bl Then
    
11.             Shell "cmd.exe /c Copy " & f & " " & mypath & "" & fon
    
12.         Else
    
13.             Set fo = fso.createfolder(mypath & "" & fon)
    
14.             Shell "cmd.exe /c Copy " & f & " " & mypath & "" & fon
    
15.         End If
    
16.     Next f
    
17.     Set fo = Nothing
    
18.     Set fs = Nothing
    
19.     Set fso = Nothing
    
20. End Sub

复制代码

ykcbf1100

练个手。。。

ykcbf1100

纯练手。。。

1. Sub ykcbf()   '//2024.5.25
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     p = ThisWorkbook.Path & ""
   
6.     For Each f In fso.GetFolder(p).Files
   
7.         If InStr(f.Name, ThisWorkbook.Name) = 0 Then
   
8.             fn = Split(fso.GetBaseName(f), "-")(0)
   
9.             d(fn) = d(fn) & "#" & f
   
10.         End If
    
11.     Next f
    
12.     For Each k In d.keys
    
13.         p1 = p & k & ""
    
14.         If Not fso.FolderExists(p1) Then fso.CreateFolder p1
    
15.         b = Split(d(k), "#")
    
16.         For x = 1 To UBound(b)
    
17.             fso.MoveFile b(x), p1
    
18.         Next
    
19.     Next
    
20.     Application.ScreenUpdating = True
    
21.     MsgBox "OK！"
    
22. End Sub
    

复制代码