[已解决]求助：分类提取图片.rar

水木 · 发表于 2015-9-12 09:51

求助：分类提取图片.rar (82.05 KB, 下载次数: 4)

dsmch · 发表于 2015-9-12 11:46

Sub Macro1()
On Error Resume Next
Dim rng As Range, mypath$$, i&, j&
mypath = ThisWorkbook.Path & "\图库"
Application.DisplayAlerts = False
For Each sht In Sheets
If sht.Name <> "查找" Then sht.Delete
Next
With Sheet1
For i = 4 To 8 '列
If Sheets(.Cells(1, i)) Is Nothing Then
With Sheets.Add(after:=Sheets(Sheets.Count))
.Name = Sheet1.Cells(1, i)
End With
End If
For j = 2 To 5 '行
Set rng = Cells(1, j).Resize(4, 1)
ActiveSheet.Shapes.AddShape(msoShapeRectangle, rng.Left, rng.Top, rng.Width, rng.Height).Select
Selection.ShapeRange.Line.Visible = msoFalse
Selection.ShapeRange.Fill.UserPicture mypath & .Cells(1, i) & "" & .Cells(j, i) & ".JPG"
Next
Next
End With
Sheet1.Activate
Application.DisplayAlerts = True
End Sub

复制代码

dsmch · 发表于 2015-9-12 11:48

………………

		自动登录	找回密码
密码			注册