|
|
Sub test()
Application.ScreenUpdating = False
Dim ar As Variant, cr As Variant
Dim i As Long, r As Long, rs As Long
Dim br(), brr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("统编代码")
r = .Cells(Rows.Count, 1).End(xlUp).Row
ar = .Range("a1:b" & r)
End With
For i = 1 To UBound(ar)
If ar(i, 1) <> "" Then
d(ar(i, 1)) = i
End If
Next i
lj = ThisWorkbook.Path & "\相片\"
For Each sh In Sheets
If sh.Name <> "统编代码" Then
sh.Select
For Each shp In sh.Shapes
shp.Delete
Next shp
xm = sh.Name
xh = d(xm)
If xh <> "" Then
sh.[ab4] = ar(xh, 2)
End If
f = Dir(lj & xm & ".jpg")
If f <> "" Then
sh.[au3].Select
If ActiveCell.MergeCells Then '判断所选单元格是否是合并单元格
cellW = ActiveCell.MergeArea.Width '是的话，cellW和cellH分别等于合并单元格的宽和高
cellH = ActiveCell.MergeArea.Height
Else
cellW = ActiveCell.Width '不是的话，cellW和cellH分别等于单元格的宽和高
cellH = ActiveCell.Height
End If
cellL = ActiveCell.Left
cellT = ActiveCell.Top
Set shpPic = ActiveSheet.Shapes.AddPicture(lj & f, msoFalse, msoTrue, cellL, cellT, -1, -1)
picW = shpPic.Width
picH = shpPic.Height
rtoW = cellW / picW * 0.98 '设置单元格和图片的比例。并设置最终比例为原始比例的98%；
rtoH = cellH / picH * 0.98 '这样的目的在于不要让图片充满整个单元格，以便可以让人看到单元格的边线。
shpPic.LockAspectRatio = msoTrue
If rtoW < rtoH Then
shpPic.ScaleHeight rtoW, msoTrue, msoScaleFromTopLeft
Else
shpPic.ScaleHeight rtoH, msoTrue, msoScaleFromTopLeft
End If
picW = shpPic.Width '根据上面确认的比例，为图片的宽和高重新赋值
picH = shpPic.Height
shpPic.IncrementLeft (cellW - picW) / 2 '移动单元格的图片，使图片位于单元格（宽和高）的中间。
shpPic.IncrementTop (cellH - picH) / 2
End If
Set f = Nothing
End If
Next sh
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-5-30 09:48
，有没有快捷方法把统编代码快速输入每个人对应的单元里面，另外每个学生的照片也快速插入对应表的照片单元格位置？谢谢……
楼主