text 插入照片调整尺寸：2018年2月8日

Posted 2021-05-03

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