文件名称：照片批量自动插入
文件大小：38KB
文件格式：XLS
更新时间：2014-11-17 12:55:31
照片批量自动插入
批量照片自动插入不再是难题，一键全插入VBA代码如下： Option Explicit Sub InsertPicture() Dim MyShape As Shape Dim r As Integer Dim c As Integer Dim PicPath As String Dim Picrng As Range With Sheet1 For Each MyShape In .Shapes If MyShape.Type = 13 Then MyShape.Delete End If Next For r = 7 To .Cells(.Rows.Count, 7).End(xlUp).Row Step 10 For c = 6 To 6 PicPath = ThisWorkbook.Path & "\" & .Cells(r, c).Text & ".jpg" If Dir(PicPath) <> "" Then Set MyShape = .Shapes.AddPicture(PicPath, False, True, 250, 250, 250, 250) Set Picrng = .Range(Cells(r - 4, c - 4), Cells(r + 1, c - 4)) With MyShape .LockAspectRatio = msoFalse .Top = Picrng.Top + 1.5 .Left = Picrng.Left + 1.5 .Width = Picrng.Width - 1.5 .Height = Picrng.Height - 1.5 .TopLeftCell = "" End With Else .Cells(r - 4, c - 4) = "暂无照片" End If Next Next End With Set MyShape = Nothing Set Picrng = Nothing End Sub Sub MyName() Dim MyName As String Dim r As Integer r = 7 MyName = Dir(ThisWorkbook.Path & "\" & "*.jpg") Do While MyName <> "" If MyName <> ".jpg" And MyName <> ".." Then Cells(r, 6) = MyName r = r + 10 Else Cells(r, 6).ClearContents End If MyName = Dir Loop Cells.Replace What:=".jpg", Replacement:="", LookAt:=xlPart, SearchOrder _ :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False End Sub