[VBA] 명단에 사진 자동으로 넣기

이번 시간에는 명단에 사진을 자동으로 넣어 보기로 하겠습니다.

 

예를 들어 매년, 매월, 또는 매주 명단이 바뀌게 되면 그에 따라 사진도 같이 바꿔줘야 되는데 상당히 번거롭습니다.

 

아래 보안구역 출입명부가 있습니다.

 

그리고 이 엑셀파일이 있는 폴더 밑에 하위폴더로 '사진파일'이 있구요.

 

그 '사진파일' 폴더에는 각 개인의 사진이 있습니다.

 

아래는 VBA코드입니다.

 

우선 현지 활성화된 시트에 있는 모든 그림을 삭제해줍니다.

 

이 작업을 안하게 되면 기존 사진이 안 지워지고 위에 새로운 사진이 덧씌워지게 됩니다.

 

Dim Pic As Object
    For Each Pic In ActiveSheet.Pictures
Pic.Delete
Next Pic

그리고 현재작업중인 엑셀의 경로를 가져옵니다.
Str1 = ActiveWorkbook.Path

i = 0
Do While Cells(6 + i, 4) <> ""

 

명단의 이름을 가져오고 그에 맞는 파일이 '사진폴더'에 있는 지 검사합니다.
Name = Cells(6 + i, 4)
str2 = Str1 & "\사진파일\" & Name & ".png"
ret = Dir(str2)

 

사진폴더에 해당사진이 있으면
If ret <> "" Then

 

해당사진의 경로를 filename2 에 저장해주고요
filename2 = Str1 & "\사진파일\" + ret

해당사진을 불러와서 Pic 개체에 넣어줍니다.
Set Pic = ActiveSheet.Pictures.Insert(filename2)

 

그리고 사진을 넣을 장소를 선택을 하고요. 명단의 옆 셀이 되겠죠
Range(Cells(6 + i, 5), Cells(6 + i, 5)).Select
Set Imagecell = ActiveCell.MergeArea

 

Pic 개체의 위치를 설정해줍니다. 아까 선택했던 셀의 좌,우,너비,높이 위치를 알려줍니다.
With Pic
  .ShapeRange.LockAspectRatio = msoFalse
  .Left = Imagecell.Left + 1
  .Top = Imagecell.Top + 1
  .Width = Imagecell.Width - 1
  .Height = Imagecell.Height - 1
End With
End If

아래 명단으로 이동하여 끝까지 반복합니다.
i = i + 1
Loop

 

코드를 실행한 결과입니다.

 

그림이 셀사이즈에 딱 맞게 잘 들어갔네요!!

 

아래는 관련 엑셀파일과 코딩 내용입니다.

그림 넣기.zip

0.20MB

 

감사합니다.

---

Dim Pic As Object
For Each Pic In ActiveSheet.Pictures
Pic.Delete
Next Pic

Str1 = ActiveWorkbook.Path
i = 0
Do While Cells(6 + i, 4) <> ""
Name = Cells(6 + i, 4)
str2 = Str1 & "\사진파일\" & Name & ".png"
ret = Dir(str2)
If ret <> "" Then
filename2 = Str1 & "\사진파일\" + ret
Range(Cells(6 + i, 5), Cells(6 + i, 5)).Select
Set Pic = ActiveSheet.Pictures.Insert(filename2)
Set Imagecell = ActiveCell.MergeArea
With Pic
.ShapeRange.LockAspectRatio = msoFalse
.Left = Imagecell.Left + 1
.Top = Imagecell.Top + 1
.Width = Imagecell.Width - 1
.Height = Imagecell.Height - 1
End With
End If
i = i + 1
Loop