[已解决]请高手帮忙解决，谢谢

jianjian053

目的：通过合同号查找出相应的四个文件夹里的图片并且显示出来，图片大小要设置成一样的！我鼓捣了两天了也不行，麻烦各位了！

最佳答案

月排行榜 / 总排行榜

dsmch

2015-3-5 12:54

………………

跳转到最佳答案楼层

dsmch

………………

jianjian053

忘记说了，可以用excel，也可用其它的，只要能达到查找并显示出来的目的就行，谢谢大家了

dsmch

1. Sub Macro1()
   
2. Dim mypath$, i&, j%, m As Shape
   
3. mypath = ThisWorkbook.Path & ""
   
4. For Each m In ActiveSheet.Shapes
   
5.     If m.Type <> 8 Then m.Delete
   
6. Next
   
7. For i = 2 To Range("a65536").End(xlUp).Row
   
8.     For j = 8 To 11
   
9.         x = Cells(i, j).Left: y = Cells(i, j).Top
   
10.         w = Cells(i, j).Width: h = Cells(i, j).Height
    
11.         ActiveSheet.Shapes.AddShape(msoShapeRectangle, x, y, w, h).Select
    
12.         Selection.ShapeRange.Fill.UserPicture mypath & Cells(1, j) & "" & Cells(i, 4) & ".jpg"
    
13.     Next
    
14. Next
    
15. End Sub

复制代码

jianjian053

dsmch 发表于 2015-3-5 12:51

你好，我是你帮我做那个新建文件夹的人，提取照片那个，很有用，谢谢您！我还需要做一个复制提取的，能再次麻烦您吗？我做了一个但是执行不了，没发给您发消息，只有留言了，我的帖子还在求助那里，麻烦您看一下，谢谢

jianjian053

dsmch 发表于 2015-3-5 12:51

Sub Macro1()
Dim fs, w, mypath$, i&, j%, wj$, wj2$
Set fs = CreateObject("scripting.filesystemobject")
mypath = ThisWorkbook.Path & "\"
w = Array("00-总库")
For i = 2 To Range("a65536").End(xlUp).Row
    For j = 0 To UBound(w)
        wj = mypath & w(j) & "\" & Cells(i, 1) & ".jpg"
        wj2 = mypath & "查找人员" & "\" & Cells(i, 1) & j + 1 & ".jpg"
        If fs.MoveFile(wj) Then fs.CopyFile wj, wj2
    Next
Next
MsgBox "所需证件拷贝完毕，谢谢使用......"
End Sub
这是将一个文件夹里的照片按照指定的名称复制到另一个文件夹里，但是原文件夹的文件还在，请问有什么办法能够将这些照片直接剪切到另一个文件夹里？谢谢