[已解决]求助：提取相同名称的图片 ...

水木

求助：提取相同名称的图片图片到工作表.rar (244.4 KB, 下载次数: 6)

2017-2-3 20:01 上传

点击文件名下载附件 恳请老师赐教！

最佳答案

月排行榜 / 总排行榜

grf1973

2017-2-7 11:30

其实那句是有用的。去掉的话，如果表中已存在要创建的工作表，会出错。除非运行前删掉。
原附件里有 sub 删除() 的，你没用上罢了。

跳转到最佳答案楼层

grf1973

1. Sub main()
   
2.     Dim Fn$, Filename$, x$
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Fn = Dir(ThisWorkbook.Path & "\*.JPG")         '读取所有jpg文件，存入字典,key为文件首字符。
   
5.     x = Left(Fn, 1)
   
6.     d(x) = Fn
   
7.     Do While Fn <> ""
   
8.         Fn = Dir
   
9.         x = Left(Fn, 1)
   
10.         If Len(x) > 0 Then d(x) = IIf(d.exists(x), d(x) & "," & Fn, Fn)
    
11.     Loop
    
12.    
    
13.     Call 删除
    
14.     For Each x In d.keys
    
15.         Sheets.Add after:=Sheets(Sheets.Count)
    
16.         xrr = Split(d(x), ",")
    
17.         With ActiveSheet
    
18.             .Name = x
    
19.             n = 0
    
20.             For i = 0 To UBound(xrr)
    
21.                 Filename = ThisWorkbook.Path & "" & xrr(i)
    
22.                 .Cells(2 * i + 1, 1).Select
    
23.                 ActiveSheet.Pictures.Insert(Filename).Select
    
24.                 .Cells(2 * i + 1, 1).RowHeight = Selection.ShapeRange.Height
    
25.             Next
    
26.         End With
    
27.     Next
    
28.     Sheets(1).Activate
    
29. End Sub

复制代码

水木

老师：您好！先谢谢您的赐教！可当我运行代码后，出现对话框。对话框提示：“For Each控件变量必须为变体或对象”，“For Each x In d.keys”   中的“x"是蓝色。再请老师赐教。期待您的最佳。

grf1973

那就稍微改一下吧。照理应该可以的。

1. Sub main()
   
2.     Dim Fn$, Filename$, x$
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Fn = Dir(ThisWorkbook.Path & "\*.JPG")         '读取所有jpg文件，存入字典,key为文件首字符。
   
5.     x = Left(Fn, 1)
   
6.     d(x) = Fn
   
7.     Do While Fn <> ""
   
8.         Fn = Dir
   
9.         x = Left(Fn, 1)
   
10.         If Len(x) > 0 Then d(x) = IIf(d.exists(x), d(x) & "," & Fn, Fn)
    
11.     Loop
    
12.    
    
13.     Call 删除
    
14.     dk = d.keys
    
15.     For k = 0 To UBound(dk)
    
16.         x = dk(k)
    
17.         Sheets.Add after:=Sheets(Sheets.Count)
    
18.         xrr = Split(d(x), ",")
    
19.         With ActiveSheet
    
20.             .Name = x
    
21.             n = 0
    
22.             For i = 0 To UBound(xrr)
    
23.                 Filename = ThisWorkbook.Path & "" & xrr(i)
    
24.                 .Cells(2 * i + 1, 1).Select
    
25.                 ActiveSheet.Pictures.Insert(Filename).Select
    
26.                 .Cells(2 * i + 1, 1).RowHeight = Selection.ShapeRange.Height
    
27.             Next
    
28.         End With
    
29.     Next
    
30.     Sheets(1).Activate
    
31. End Sub

复制代码

grf1973

或者把2楼代码中数据类型定义
Dim Fn$, Filename$, x$
中对 x 的定义去掉。

水木

grf1973 发表于 2017-2-6 09:31
或者把2楼代码中数据类型定义
Dim Fn$, Filename$, x$
中对 x 的定义去掉。

老师：您好！代码运行后，出现对话框提示。内容是“编译错误：子过程或函数未定义。”代码中“Call 删除”为蓝色字体。请老师赐教。

grf1973

把那句删掉。

水木

grf1973 发表于 2017-2-6 20:47
把那句删掉。

老师：您好！代码运行后，图片也提取出来了，结束时出现对话框。内容是“*400”。请老师赐教。

grf1973

其实那句是有用的。去掉的话，如果表中已存在要创建的工作表，会出错。除非运行前删掉。
原附件里有 sub 删除() 的，你没用上罢了。

水木

grf1973 发表于 2017-2-7 11:30
其实那句是有用的。去掉的话，如果表中已存在要创建的工作表，会出错。除非运行前删掉。
原附件里有 sub  ...

非常感谢老师的赐教！