[땡큐엑셀vba & 엑셀매크로] 파일명에 해당하는 이미지 삽입하기

 

'http://kin.naver.com/qna/detail.nhn?d1id=1&dirId=102020101&docId=279091932

'A열에는 파일명
'B열에는 파일명에 해당하는 이미지 불러오기


'1) 이미지폴더를 선택한후
'2) A열에서 이미지파일과 같은 이름을 찾아
'3) 그 옆셀에 셀크기에 맞게 이미지 출력
'4) 2~3번과정을 반복수행


'
'source by 땡큐엑셀vba & 엑셀매크로
'
Sub insert_Pictures_Matching_Name()

    Dim fileName As String
    Dim strPath As String
    Dim strType As String
    Dim C As Range
    Dim strName As String


    '화면 업데이트 중지
    Application.ScreenUpdating = False
    

    
    '1)이미지 폴더 선택
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show

        If .SelectedItems.Count = 0 Then
            Exit Sub
        Else
            strPath = .SelectedItems(1) & "\"
        End If
    End With
 
    '이미지 폴더를 선택 안했을 때
    If strPath = "" Then
        MsgBox "폴더를 먼저 선택하세요"
        Exit Sub
    End If
    
    '이미지 타입(해당하는 타입으로 변경하여 사용하시면 됩니다)
    strType = "*.png"
    
    
    '이미지 폴더에서 해당 이미지타입의 파일을 검색
    fileName = Dir(strPath & strType)
    If fileName = "" Then
        MsgBox "폴더에 파일이 없습니다."
        Exit Sub
    End If
    

    '해당 이미지파일이 없을때 까지 루프
    Do While fileName <> ""
        
        '확장자를 뺀 파일이름만
        strName = Split(fileName, ".")(0)
        

        '2)이미지파일과 같은 이름을 시트에서 검색
        Set C = ActiveSheet.UsedRange.Find(fileName, , , xlPart)
        If Not C Is Nothing Then

            '3)이미지 파일을 시트에 삽입
            ActiveSheet.Pictures.Insert(strPath & fileName).Select
            
            'A열에는 이름이 B열에는 이미지를
            Set C = C.Offset(0, 1)
            
            '이미지를 B열의 셀크기에 맞게 조정한후 복사 그리고 삭제
            With Selection
                .Name = "Temp"
                .ShapeRange.LockAspectRatio = msoFalse
                .Height = C.Height - 4
                .Width = C.Width - 4
                
                .Copy
                ActiveSheet.PasteSpecial Link:=False
                ActiveSheet.Pictures("Temp").Delete
            End With
            
            'B열의 셀위치로 이동
            With Selection
                .Left = C.Left + 2
                .Top = C.Top + 2
            End With
        End If
        
        '다음파일
        fileName = Dir
        
    Loop
    
    
    
LoopEnd:
    '화면 업데이트 재개
    Application.ScreenUpdating = True
    
    MsgBox "작업이 완료되었습니다", vbInformation, "땡큐엑셀vba & 엑셀매크로"
End Sub

 

내용과동일한이미지불러오기-FileDialog_Dir_Split_Find_Pictures_Offset-땡큐엑셀vba.xlsm

0.07MB