怎么批量新建文件夹并把对应的图片移动到新建文件夹里面

limonet

Sub limonet()
    Dim i%, Dic As Object, H$
    Set Dic = CreateObject("scripting.dictionary")
    For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
        Dic(Cells(i, "B").Value) = Dic(Cells(i, "B").Value) & "','" & Cells(i, "A") & ".jpg"
    Next i
    For i = 0 To Dic.Count - 1
        H = H & "';'" & Dic.keys()(i) & "'=" & Mid(Dic.items()(i), 3)
    Next i
    CreateObject("wscript.shell").Run "powershell push-location " & ThisWorkbook.Path _
    & ";$h=@{" & Mid(H, 3) & "'};md $h.keys;foreach ($i in $h.keys) { move $h[$i] $i}", 0
End Sub

ykcbf1100

练手，图片文件归类

ykcbf1100

练习，图片文件归类

1. Sub ykcbf()   '//2024.6.14,按要求归类图片文件
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set fso = CreateObject("scripting.filesystemobject")
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     p = ThisWorkbook.Path & ""
   
7.     Application.ScreenUpdating = False
   
8.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
9.     arr = sh.UsedRange
   
10.     For i = 2 To UBound(arr)
    
11.         s = arr(i, 2)
    
12.         If s <> Empty Then
    
13.             If Not d.exists(s) Then
    
14.                 d(s) = arr(i, 1)
    
15.             Else
    
16.                 d(s) = d(s) & "|" & arr(i, 1)
    
17.             End If
    
18.         End If
    
19.     Next
    
20.     For Each k In d.keys
    
21.         p1 = p & k & ""
    
22.         If Not fso.FolderExists(p1) Then fso.CreateFolder p1
    
23.         For Each f In fso.GetFolder(p).Files
    
24.             If LCase$(f.Name) Like "*.jpg" Then
    
25.                 fn = fso.GetBaseName(f)
    
26.                 If InStr(d(k), fn) Then fso.MoveFile f, p1
    
27.             End If
    
28.         Next f
    
29.     Next
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub
    

复制代码