Excel错误地放置图像

我试图在Excel 2013中帮助她的VBA同事。它看起来像macros从指定的path成功拉入图像，但它将每张照片转储到单元格A1。

有什么想法吗？

Sub DeleteAllPictures() Dim S As Shape For Each S In ActiveSheet.Shapes Select Case S.Type Case msoLinkedPicture, msoPicture S.Delete End Select Next End Sub Sub UpdatePictures() Dim R As Range Dim S As Shape Dim Path As String, FName As String 'Setup the path Path = "G:\In Transit\Carlos\BC Website images" 'You can read this value also from a cell, eg: 'Path = Worksheets("Setup").Range("B1") 'Be sure the path has a trailing backslash If Right(Path, 1) <> "\" Then Path = Path & "\" 'Visit each used cell in column A For Each R In Range("B1", Range("B" & Rows.Count).End(xlUp)) 'Try to get the shape Set S = GetShapeByName(R) 'Found? If S Is Nothing Then 'Find the picture eg "C:\temp\F500.*" FName = Dir(Path & R & ".*") 'Found? If FName <> "" Then Set S = InsertPicturePrim(Path & FName, R) End If End If If Not S Is Nothing Then 'Show the error if the name did not match the cell If S.Name <> R Then R.Interior.Color = vbRed With R.Offset(0, 1) 'Move the picture to the cell on the right side S.Top = .Top S.Left = .Left 'Resize it S.Width = .Width 'Remove the aspect ratio by default if necessary 'S.LockAspectRatio = False If S.LockAspectRatio Then 'Make it smaller to fit the cell if necessary If S.Height > .Height Then S.Height = .Height Else 'Stretch the picture S.Height = .Height End If End With 'Move it behind anything else S.ZOrder msoSendToBack Else R.Offset(0, 1) = "No picture available" End If Next End Sub Private Function GetShapeByName(ByVal SName As String) As Shape 'Return the shape with SName, Nothing if not exists On Error Resume Next Set GetShapeByName = ActiveSheet.Shapes(SName) End Function Private Function InsertPicturePrim(ByVal FName As String, ByVal SName As String) As Shape 'Inserts the picture, return the shape, Nothing if failed Dim P As Picture On Error Resume Next 'Insert the picture Set P = ActiveSheet.Pictures.Insert(FName) 'code to resize With P .ShapeRange.LockAspectRatio = msoFalse .Height = ActiveCell.Height .Width = ActiveCell.Width .Top = ActiveCell.Top .Left = ActiveCell.Left .Placement = xlMoveAndSize End With Set P = Nothing 'code to resize 'Success? If Not P Is Nothing Then 'Return the shape Set InsertPicturePrim = P.ShapeRange(1) 'Rename it, so we can easily find it later P.Name = SName End If End Function 

Answer 1

简短的回答是：您的macros正在插入图片在选定的单元格。 在插入行之前更改select，并且应该在每一行插入它。

在这个例子中，我正在select单元格的左边的单元格，你从中拉取名称值。

  If FName <> "" Then 'select the cell 1 to the left of the cell containing the image name R.Offset(0,-1).select Set S = InsertPicturePrim(Path & FName, R) End If