将图像插入文件夹中的 excel 单元格

Question

我是 VBA 程序的新手我不确定如何执行我的要求

这里，我的要求是在我的 Excel sheet 中有 3 列。 列名称（S.no、S、E）。我想 根据匹配的 S.no 和图像名称 将图像插入到 S 和 E 列，我所有的图像都在另一个文件夹 .

示例输入格式

S.no      S         E

1       
2       
99

文件夹中的图片名称

c:\iamges\E_001.jpg

c:\images\E_002.jpg

c:\images\S_002.jpg

c:\images\E_099.jpg

单元格中要求的输出格式

S.no      S          E

1                    E_001.jpg

2       S_002.jpg    E_002.jpg

99                   E_099.jpg

此处 S.no 1 匹配 E_001.jpg 图片

S.no 2 匹配文件夹

中的 S_002.jpg 和 E_002.jpg 图片

以类似的方式匹配所有图像并填充到单元格中。

我正在尝试以下代码

strFolder = "C:\images" 'change the path accordingly
    If Right(strFolder, 1) <> "\" Then
        strFolder = strFolder & "\"
    End If

    Set rngCell = Range("c5") 'starting cell

    strFileName = Dir(strFolder & "E*.jpg", vbNormal) 'filter for .jpg files

    Do While Len(strFileName) > 0
        Set objPic = ActiveSheet.Pictures.Insert(strFolder & strFileName)
        With objPic
             .ShapeRange.LockAspectRatio = False
            .Left = rngCell.Left
            .Top = rngCell.Top
            .Height = rngCell.Height
            .Width = rngCell.Width
            .Placement = xlMoveAndSize
        End With
        Set rngCell = rngCell.Offset(1, 0)
        strFileName = Dir
    Loop

上面的代码将所有图像填充到单元格中，而不匹配文件名和 S.no

Answer 1

我根据参考试过了。

Sub AddPictures()
 Dim myPic As Picture
 Dim wkSheet As Worksheet
 Dim myRng As Range
 Dim myCell As Range

 Dim rowCount2 As Long

     Set wkSheet = Sheets(2) ' -- Working sheet

    '-- The usual way of finding used row count for specific column
    rowCount2 = wkSheet.Cells(wkSheet.Rows.Count, "A").End(xlUp).Row

    If rowCount2 <> 0 Then
        Set myRng = wkSheet.Range("A2", wkSheet.Cells(wkSheet.Rows.Count, "A").End(xlUp)) 'S.no starting from cell A2

        For Each myCell In myRng.Cells
               If Len(myCell) = 1 Then
                 myCell2 = "E_00" & myCell & ".jpg"
                 myCell3 = "S_00" & myCell & ".jpg"
                 ElseIf Len(myCell) = 2 Then
                 myCell2 = "E_0" & myCell & ".jpg"
                 myCell3 = "S_0" & myCell & ".jpg"
                 Else
                 myCell2 = "E_" & myCell & ".jpg"
                 myCell3 = "S_" & myCell & ".jpg"
                 End If
                 myCell1 = "c:\iamges\\" & myCell2

               If Trim(myCell1) = "" Then
                    MsgBox "No file path"

               ElseIf Dir(CStr(myCell1)) = "" Then

                    MsgBox "Error Image" & myCell & " Doesn't exist!"

               Else

                    Set myPic = myCell.Offset(0, 1).Parent.Pictures.Insert(myCell1)

                    With myPic '1 columns to the right of A ( is B)
                        '-- resize image here to fit into the size of your cell
                        .ShapeRange.LockAspectRatio = False
                        myPic.Top = myCell.Offset(0, 1).Top
                        myPic.Width = myCell.Offset(0, 1).Width
                        myPic.Height = myCell.Offset(0, 1).Height
                        myPic.Left = myCell.Offset(0, 1).Left
                        myPic.Placement = xlMoveAndSize
                    End With

               End If

                myCell1 = "c:\iamges\\" & myCell3
               If Trim(myCell1) = "" Then
                    MsgBox "No file path"
               ElseIf Dir(CStr(myCell1)) = "" Then
                    MsgBox "Solution image " & myCell & " Doesn't exist!"
               Else
                    'myCell.Offset(0, 1).Parent.Pictures.Insert (myCell1)
                    Set myPic = myCell.Offset(0, 2).Parent.Pictures.Insert(myCell1)

                    With myPic '1 columns to the right of A ( is C)
                        '-- resize image here to fit into the size of your cell
                        .ShapeRange.LockAspectRatio = False
                        myPic.Top = myCell.Offset(0, 2).Top
                        myPic.Width = myCell.Offset(0, 2).Width
                        myPic.Height = myCell.Offset(0, 2).Height
                        myPic.Left = myCell.Offset(0, 2).Left
                        myPic.Placement = xlMoveAndSize
                    End With

               End If


        Next myCell

    Else
        MsgBox "File is Empty"
    End If
End Sub

引用自reading the image

将图像插入文件夹中的 excel 单元格

Inserting Images in to excel cell from folder

ms-office