|
Sub 提取数据和插入图片()
Application.ScreenUpdating = False
lj = ThisWorkbook.path & "\图片\"
With ActiveSheet
For Each shp In .Shapes
If shp.TopLeftCell.Row > 1 Then
shp.Delete
End If
Next shp
.[a1].CurrentRegion.Offset(1) = Empty
f = Dir(lj & "*.jpg")
n = 1
Do While f <> ""
n = n + 1
zd = Split(f, ".")(0)
.Cells(n, 1) = Right(zd, 6)
.Cells(n, 2) = Left(zd, Len(zd) - 6)
.Cells(n, 3).Select
.Pictures.Insert(lj & f).Select
With Selection.ShapeRange
Selection.ShapeRange.LockAspectRatio = msoFalse
.Top = Cells(n, 3).Top + 1
.Left = Cells(n, 3).Left + 1
.Width = Cells(n, 3).Width
.Height = Cells(n, 3).Height
End With
f = Dir
Loop
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub |
|