폴더 선택 후 셀 크기에 맞게 이미지 불러오기

지식인에 올라온 질문.

폴더를 선택하면 폴더 안에 있는 JPG 파일을 모두 불러오되

셀의 크기에 맞게 불러오는 코드를 질문하였다.

1. 폴더를 선택한다.

2. 폴더 내에 있는 이미지 파일을 불러온다.

3. 셀 크기에 맞게 A,B열에 이미지를 삽입한다.

Sub getPicture()
 
    Dim imgPos As Range
    Dim strPath As String, fileName As String
    Dim cR As Integer, cC As Integer
    
    '작업속도 상승
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    
    '엑셀파일의 위치와 동일한 경로설정 및 폴더 선택
    ChDir ThisWorkbook.Path
        With .FileDialog(msoFileDialogFolderPicker)
            .Show
            
            '폴더 내 파일이 없으면 매크로 종료
            If .SelectedItems.Count = 0 Then
                Exit Sub
            Else
                strPath = .SelectedItems(1) & "\"
            End If
        End With
    End With
    
    'jpg파일 경로를 설정하고 기존 JPG파일 삭제
    fileName = Dir(strPath & "*.jpg")
    ActiveSheet.Pictures.Delete
 
    '폴더에 JPG파일이 없으면 메시지 출력 후 매크로 종료
    If fileName = "" Then
        MsgBox "폴더에 JPG 파일이 없음."
        Exit Sub
    End If
    
    '폴더 내 모든 JPG파일 불러옴
    cR = 1
    Do While fileName <> ""
    
        'A,B열에 이미지 삽입
        For cC = 1 To 2
            Set imgPos = Cells(cR, cC)
            With ActiveSheet.Pictures.Insert(strPath & fileName).ShapeRange
                .LockAspectRatio = msoFalse
                .Height = imgPos.Height
                .Width = imgPos.Width
                .Left = imgPos.Left
                .Top = imgPos.Top
            End With
            fileName = Dir
        Next cC
        cR = cR + 1
    Loop
    
    '작업속도 복구
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

+ 이미지폴더 +

+ 매크로 적용 후 +

질문.xlsm

Temp.zip