Вставка изображений в ячейку Excel из папки - PullRequest
Новая
       14

Вставка изображений в ячейку Excel из папки

0 голосов
/ 18 сентября 2018

Я очень новичок в программе VBA, я не уверен, как выполнить мое требование

Здесь мое требование В моем листе Excel есть 3 столбца. Имена столбцов (S.no, S, E) . Я хочу вставить изображения в столбцы S и E на основе соответствующих S.no и имени изображения , все мои изображения находятся в другой папке.

пример формата ввода 

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

1 Ответ

0 голосов
/ 18 сентября 2018

Я пытался на основании ссылки. 

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

Справка с чтения изображения

...