OfficeTutor.com
배움터 나눔터 교육센터 오튜장터
 통합검색  
  Home > 나눔터 > 엑셀 > 묻고답하기
엑셀
워드
액세스
파워포인트
아웃룩
프런트페이지
인포패스
원노트
비지오
쉐어포인트
포토드로우
퍼블리셔
오피스공통
MVP 안내
MVP 명예의 전당
MVP 카페

 

 

 

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

 빨강색 (ghkdudals)

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

 - 엑셀 버전(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

 
 
회사소개 | 이용약관 | 개인정보 처리방침 | 회원정보수정 | 교육신청 및 문의 | 이메일무단수집거부 위로

오피스튜터 블로그 오피스튜터페이스북 오피스튜터유투브
110-722 서울 종로구 세종대로23길 47, 601-74 ㈜오피스튜터 ☎1544-4102 대표이사 : 전경수
개인정보관리책임자 : 이희진(privacy@officetutor.com) 사업자등록번호 120-86-14501
통신판매업신고 2013-서울종로-0547
norton
Copyright ⓒ OfficeTutor.com 이 페이지의 저작권은 ㈜오피스튜터와 콘텐츠 제공자에게 있습니다. 무단 복제를 금합니다.
Microsoft 및 Office 로고는 미국, 대한민국 및/또는 기타 국가에서의 Microsoft Corporation 등록 상표 또는 상표입니다.