나눔터  
  HOME > 나눔터 > 묻고답하기 > 엑셀
엑셀
엑셀에 대한 질문과 답변을 올려주세요. 단, 취지에 맞지 않는 글은 운영자가 삭제합니다.
 "000 님, 도와주세요", "부탁 드립니다.", "급합니다!" 등과 같이 막연한 제목을 달지 말아주세요.
[필독] 빠르고 정확한 답변을 얻는 16가지 Tip !
[필독] 저작권법 개정에 따른 이용안내
작성자:  

 박기남 (photomate)

추천:  2
파일:     insert_FileName_With_Pictures .xlsm (19.1KB) 조회:  2112
제목:   매크로 문의
     
  * 답변하시는 분들께 도움이 되도록 자신의 환경을 아래 항목 옆에 기재해 주세요.

 - 엑셀 버전(95,97,2000,xp,2003,2007):

* 아래줄에 질문을 작성하세요 >>


사진과 파일명을 불러와 라벨지에 출력한는 매크로를 만드려고 합니다
매크로 실행하면 사진과 파일명이 오른쪽으로 계속 배열되는데
4개의 파일 이후마다 다음줄로 배열되게 할 수는 없을까요
그리고 파일명 앞에 폴더명 함께 나오도록 하고싶습니다










Option Explicit

Sub insert_FileName_With_Pictures()
    
    Dim fileNames As Variant     '모든 파일 넣을 배열 변수
    Dim i As Long                        '반복구문에 사용할 변수
    Dim var                                  '파일이름 쪼개어 넣을 변수
    Dim strName As String          '추출한 파일이름 넣을 변수
    Dim A As Range                     '파일이름 들어갈 영역을 넣을 변수
    Dim C As Range                     '그림 들어갈 영역을 넣을 변수
    
    Application.ScreenUpdating = False       '화면 업데이트 (일시)정지

    Set A = ActiveCell                   '현재 선택한 셀을 변수에 넣음
    
    fileNames = Application.GetOpenFilename("Picture Files (*.jp*; *.gif; *.png),*.xls", , _
    "그림 파일을 선택", MultiSelect:=True)         '그림 파일을 선택
    
    If TypeName(fileNames) = "Boolean" Then Exit Sub    '취소 선택 시 매크로 종료
    
    For i = 1 To UBound(fileNames)   '선택한 파일 개수만큼 반복
        var = Split(fileNames(i), "\")       '\ 로 전체이름을 나누어 배열에 넣음
        strName = var(UBound(var))     '제일 뒤의 파일 이름만 추출
        
        A = strName                         '추출한 이름을 셀에 뿌림
        
        ActiveSheet.Pictures.Insert(fileNames(i)).Select  '각 그림파일 삽입
        
        If A.Offset(-1).MergeCells Then         '만약 이름 윗셀이 셀병합 셀이면
            Set C = A.Offset(, -1).MergeArea   '셀병합 셀을 C에 넣음
        Else                                                    '셀병합셀 아닐 경우
            Set C = A.Offset(, -1)                      '그냥 바로 윗셀을 C에 넣음
        End If
                
        With Selection                              '선택된 그림파일
            .Name = "Temp#"                     '(임시로) 이름을 "Temp#"로 지정
            .ShapeRange.LockAspectRatio = msoFalse  '그림의 가로/세로비율 고정 해제
            .Height = C.Height - 4                '그림의 가로크기 지정
            .Width = C.Width - 4                  '그림의 세로크기 지정
            
            .Copy                                           '그림을 복사
            ActiveSheet.PasteSpecial Link:=False   '그림 링크깨고 붙여넣기
            ActiveSheet.Pictures("Temp#").Delete     '원본 그림파일 삭제
        End With
            
        With Selection                      '(복사되어)선택된 그림파일
            .Left = C.Left + 2              '그림의 왼쪽위치 지정
            .Top = C.Top + 2              '그림의 윗쪽위치 지정
        End With
    
        Set A = A.Offset(, 2)              '이름 들어갈 위치를 오른쪽으로 하나씩 늘려감
    Next i
    
    
    Set A = Nothing                           '개체변수 초기화(메모리 비우기)
    Set C = Nothing
End Sub
 
[불량 게시물 신고]  
        
  

작성일 : 2019-07-22(09:43)
최종수정일 : 2019-07-22(09:43)
 


 ◎ 관련글

  제 목   작성자   날짜
매크로 문의 박기남 2019-07-22
[RE]매크로 문의 dew 2019-07-22