插入照片调整尺寸:2018-2-8
Sub test()
Dim arr, i&, r&, p$, pic$
arr = Sheet1.Range("a1").CurrentRegion
p = ThisWorkbook.Path & "\照片\"
For i = 2 To UBound(arr)
With Sheet2
r = .[a65536].End(3).Row
.Rows((i - 2) * 10 + 1 & ":" & r).Copy .Rows(r + 2)
.Cells(r - 8, 2) = arr(i, 1)
.Cells(r - 7, 2) = arr(i, 2)
.Cells(r - 7, 4) = arr(i, 3)
.Cells(r - 6, 2) = arr(i, 4)
.Cells(r - 5, 3) = arr(i, 5)
.Cells(r - 4, 6) = arr(i, 6)
.Cells(r - 3, 3) = "'" & arr(i, 7)
.Cells(r - 2, 3) = "'" & arr(i, 8)
.Cells(r - 1, 3) = arr(i, 9)
.Cells(r, 3) = arr(i, 10)
pic = Dir(p & arr(i, 1) & ".*")
If pic <> "" Then
.Cells(r - 8, 5).Select
.Pictures.Insert(p & pic).Select
Selection.Width = .Cells(r - 8, 5).MergeArea.Width
Selection.Height = .Cells(r - 8, 5).MergeArea.Height
End If
End With
Next i
ActiveCell.Select
End Sub
补充内容 (2016-7-10 10:37):
.Pictures.Insert(p & pic).Select
Selection.Top = .Cells(r - 8, 5).Top
Selection.Left = .Cells(r - 8, 5).Left
Selection.Width = .Cells(r - 8, 5).MergeArea.Width
Selection.Height = .Cells(r - 8, 5).MergeArea.Height