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

Question

我对 VBA 程序非常陌生，我不确定如何执行我的要求

在这里，我的要求是在我的 Excel 表中有 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 不匹配

标签： ms-office

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

来自阅读图像的参考