|
* 답변하시는 분들께 도움이 되도록 자신의 환경을 아래 항목 옆에 기재해 주세요.
- 엑셀 버전(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
이같은 방법말고 시트 또한 자동으로 넘어가며 사진삽입되는 방법은 없을지 궁금합니다. |
|