代码之家 › 专栏 › 技术社区 › dondapati

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

ms-office

dondapati · 技术社区 · 6 年前

列名(序号、S、E) 我想 根据匹配的序号和图像名称,将图像插入到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 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

1 回复 | 直到 6 年前

dondapati 6 年前

我根据参考资料试过了。

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