Sub sleep(T As Long) Dim time1 As Long time1 = timeGetTime Do DoEvents Loop While timeGetTime - time1 < T End Sub Sub getpicture() Dim d, i&, sp As Shape, arr, xb As Workbook '设置图片库数组 Set xb = GetObject(ActiveWorkbook.path & "图片库.xlsx") 'Set xb = GetObject("C:图片库.xlsx") Set d = CreateObject("scripting.dictionary") For Each sp In xb.Sheets(1).Shapes If sp.Type = msoPicture Then Set d(sp.TopLeftCell.Offset(, -1).Value) = sp End If Next '读取首行 Dim y As Double y = Selection.Column() '列数 arr = ActiveSheet.Range(Cells(1, y - 1), Cells(65536, y - 1).End(3)) For i = 1 To UBound(arr) If d.exists(arr(i, 1)) Then sleep 100 d(arr(i, 1)).Copy Cells(i, y).Select On Error Resume Next ActiveSheet.Paste End If Next ActiveWindow.ScrollRow = 1 End Sub Sub deletepicture() Dim Tupian As Shape For Each Tupian In ActiveSheet.Shapes If Tupian.Name Like "Picture *" Then Tupian.Delete Next End Sub Sub getNetPic() Dim d, i&, sp As Shape, arr, xb As Workbook Dim rg As Range, shp As Shape, url '读取首行 Dim y As Double y = Selection.Column() '列数 arr = ActiveSheet.Range(Cells(1, y - 1), Cells(65536, y - 1).End(3)) For i = 1 To UBound(arr) Cells(i, y).Select Set rg = Cells(i, y) url = arr(i, 1) If InStr(1, url, "http") = 0 Then url = "http:" & arr(i, 1) End If If InStr(url, "jpg") > 0 Then ActiveSheet.Shapes.AddShape(msoShapeRectangle, rg.Left, rg.Top, rg.Width, rg.Height).Select Selection.ShapeRange.Fill.UserPicture url End If On Error Resume Next Next ActiveWindow.ScrollRow = 1 End Sub Sub 工具栏() With Application.CommandBars.Add(, , , True) With .Controls.Add .Caption = "匹配图片" .TooltipText = "匹配图片" .OnAction = "getpicture" .Style = msoButtonIconAndCaption End With .Visible = True With .Controls.Add .Caption = "清除图片" .TooltipText = "清除图片" .OnAction = "deletepicture" .Style = msoButtonIconAndCaption End With .Visible = True With .Controls.Add .Caption = "匹配网络图片" .TooltipText = "匹配网络图片" .OnAction = "getNetPic" .Style = msoButtonIconAndCaption End With .Visible = True End With End Sub