将图片放到指定文件夹里

tiantao186

图片放到指定文件夹里

longwin

Sub 图片放文件夹里()
    arr = Range("A2:F" & [A1].End(4).Row)
    For i = 1 To UBound(arr)
        For j = 2 To UBound(arr, 2)
        If arr(i, j) <> "" Then
            wjm = arr(i, j)
            ywj = ThisWorkbook.Path & "\图片源\" & wjm
            mbwj = ThisWorkbook.Path & "\" & arr(i, 1) & "\" & wjm
            Name ywj As mbwj
        End If
    Next
Next
End Sub

limonet

关键字：hashtable+md+move

limonet

Sub limonet()
    Dim i%, j%, h$
    For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
        If Cells(i, "B") <> "" Then
            j = 2
            Do While Cells(i, j) <> ""
                j = j + 1
            Loop
            If 2 = j - 1 Then
                h = h & "';'" & Cells(i, "A") & "'='" & Cells(i, j - 1)
            Else
                h = h & "';'" & Cells(i, "A") & "'='" & Join(Application.Transpose(Application.Transpose(Range(Cells(i, 2), Cells(i, j - 1)))), "','")
            End If
       End If
    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

limonet

Sub limonet()
    Dim i%, j%, h$
    For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
        If Cells(i, "B") <> "" Then
            h = h & "';'" & Cells(i, "A") & "'='" & Join(Application.Transpose(Application.Transpose(Range(Cells(i, 2), Cells(i, 6)))), "','")
        End If
    Next i
    h = Replace(Mid(h & "'", 3), ",''", "")
    CreateObject("wscript.shell").Run "powershell push-location " & ThisWorkbook.Path _
    & "\图片源;$h=@{" & h & "};md @($h.Keys);ForEach ($i in $h.Keys){Move $h[$i] $i}", 0
End Sub

ykcbf1100

附件供参考。。。

第一步和第二步完全可以放到一起操作的。

ykcbf1100

参与一下。。。

1. Sub 图片放文件夹里()
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     Set Sh = ThisWorkbook.Sheets("Sheet1")
   
7.     With Sh
   
8.         r = .Cells(Rows.Count, 1).End(3).Row
   
9.         arr = .[a1].Resize(r, 6)
   
10.     End With
    
11.     For i = 2 To UBound(arr)
    
12.         For j = 2 To UBound(arr, 2)
    
13.             If arr(i, j) <> Empty Then
    
14.                 s = arr(i, j)
    
15.                 d(s) = arr(i, 1)
    
16.             End If
    
17.         Next
    
18.     Next
    
19.     p = ThisWorkbook.Path & ""
    
20.     p1 = p & "图片源"
    
21.     For Each f In fso.GetFolder(p1).Files
    
22.         s = f.Name
    
23.         If d.exists(s) Then
    
24.             p2 = p & d(s) & ""
    
25.             fso.MoveFile f, p2
    
26.         End If
    
27.     Next f
    
28.     Set d = Nothing
    
29.     Application.ScreenUpdating = True
    
30.     MsgBox "OK！"
    
31. End Sub
    

复制代码