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

 빨강색 (ghkdudals)

추천:  2
파일:     사진대장.xlsx (50.8KB) 조회:  2395
제목:   사진자동삽입
     
  * 답변하시는 분들께 도움이 되도록 자신의 환경을 아래 항목 옆에 기재해 주세요.

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

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

안녕하세요 도움을 받고자 글을쓰게 되었습니다. 엑셀로 내업을 하는데 사진대장을 만듭니다. 첨부파일과 같이 시트마다 4장 사진을 넣고있는데 많을때는 수백장사진을 바꿔넣다보니 힘이듭니다.
다른곳에 검색해보니 열,행 몇칸씩 정해서 사진넣는 VBA는 찾았지만
시트마다 4장씩 넣는 방법을 모르겠습니다.
다음은 제가 찾았던 VBA입니다.

Option Explicit
 Sub insert_Pictures_Column_Row()

    Dim fileName As String               '각 파일 이름을 넣을 변수
    Dim strPath As String                 '폴더의 경로를 넣을 변수
    Const 열시작 As Integer = 1        '첫 그림이 들어갈 열의 위치 넣을 변수
    Const colSkip As Integer = 4       '(열방향)그림 사이 건너뛸 열의 개수
    Const 열개수 As Integer = 2        '그림의 전체 열개수 넣을 변수
    Dim 행시작 As Long                   '첫 그림이 들어갈 행의 위치 넣을 변수
    Const rowSkip As Long = 1         '(행방향) 그림 사이 건너뛸 행의 개수
    Dim cnt As Integer                     '열의 개수 변경에 사용할 카운터 넣을 변수
    Dim cntC As Integer                   '열방향 위치 넣을 변수
    Dim C As Range                        '각 그림들어갈 셀을 넣을 변수

        
     Application.ScreenUpdating = False   '화면 업데이트 (일시) 정지
    행시작 = 6                                       '첫 그림이 들어갈 행의 위치
    
     With Application.FileDialog(msoFileDialogFolderPicker)  '폴더선택 창에서
        .Show                                            '폴더 선택창 띄우기
 
         If .SelectedItems.Count = 0 Then        '취소 선택 시
            Exit Sub                                      '매크로 중단
        Else
             strPath = .SelectedItems(1) & "\"   '폴더 경로를 변수에 넣음
        End If
     End With


   
     ActiveSheet.Pictures.Delete                '기존 사진들 삭제
    fileName = Dir(strPath)                        '(폴더내)각 그림파일 이름을 변수에 넣음
 
     If fileName = "" Then                           '폴더에 파일이 없으면
        MsgBox "폴더에 파일이 없습니다."   '메시지 출력
        Exit Sub                                       '매크로 중단
    End If

    
     Do While fileName <> ""                      '이름이 없지 않다면, 즉, 파일이 존재하면
    
         ActiveSheet.Pictures.Insert(strPath & fileName).Select  '각 그림파일 삽입
        With Selection                                '선택된 그림파일
            .Name = "Temp#"                         '(임시로) 이름을 "Temp"로 지정
            .ShapeRange.LockAspectRatio = msoFalse  '그림의 가로/세로크기 고정 해제

 

            Set C = Cells(행시작, 열시작 + cntC)  '그림이 들어갈 셀을 변수에 넣음
            
             If C.MergeCells Then                  '만약 셀병합 셀이면
                Set C = C.MergeArea              '셀병합 셀을 C에 넣음
            End If

            .Height = C.Height - 9.16                  '그림의 가로크기 지정
            .Width = C.Width - 6.88                     '그림의 세로크기 지정
            
             .Copy                                         '그림을 복사
            ActiveSheet.PasteSpecial Format:="Picture (JPEG)", Link:=False '그림 링크깨고 붙여넣기
            ActiveSheet.Pictures("Temp#").Delete '원본 그림파일 삭제
        End With
         
         With Selection                                 '(복사되어)선택된 그림파일
            .Left = C.Left + 4                          '그림의 왼쪽위치 지정
            .Top = C.Top + 6                         '그림의 윗쪽위치 지정
        End With
             
         cnt = cnt + 1                                   '카운트를 1씩 늘려감
        cntC = cntC + colSkip + 1                 '그림의 열방향 위치 늘려감
        If cnt = 열개수 Then                         '카운터가 열개수에 도달하면
            cnt = 0                                       '(재사용 위하여)카운터 초기화
            cntC = 0                                     '(재사용 위하여)열위치 초기화
            행시작 = 행시작 + rowSkip + 1       '행 위치 늘려감
        End If
         
         fileName = Dir                                 '다음 파일을 파일이름에 넣음
    Loop                                                 '무한 반복
    
End Sub

이같은 방법말고 시트 또한 자동으로 넘어가며 사진삽입되는 방법은 없을지 궁금합니다.
 
[불량 게시물 신고]  
        
  

작성일 : 2018-12-04(18:13)
최종수정일 : 2018-12-04(18:13)
 


 ◎ 관련글

  제 목   작성자   날짜
사진자동삽입 빨강색 2018-12-04
[RE]사진자동삽입 dew 2018-12-05