|
* 답변하시는 분들께 도움이 되도록 자신의 환경을 아래 항목 옆에 기재해 주세요.
- 엑셀 버전(95,97,2000,xp,2003,2007): 2013
* 아래줄에 질문을 작성하세요 >>
안녕하세요! vba 초보이지만 업무에 필요해서 이것저것 검색해보며 매크로를 작성 중에 있습니다. 참고해서 어느 정도 틀이 잡힌 것 같은데 원하는 결과가 안나와서 질문드립니다ㅜㅜ
원하는 결과: 셀 값과 동일 이름을 가진 jpg 이미지가 셀 안에 3의 여유공간을 가지고 삽입되는 것 (링크 말고 엑셀이 이미지 내에 포함되었으면 좋겠어요! 그래서 addpicture을 썼습니다.)
예를 들어 컴퓨터 라고 입력되어 있는 셀에, 선택한 파일 내에 있는 컴퓨터.jpg 이미지가 이미지 비율 유지된 채로 3의 여유공간을 가지고 삽입되는 것
현재 상태: A1셀에 모든 이미지가 삽입됩니다. addpicture 후 이름에 맞게 각 이미지가 제자리를 찾아갈 수 있도록 함수를 설정해놓았다고 생각했는데 무엇이 잘못된 걸까요? 도움 주시면 감사합니다!
현재 매크로는 다음과 같습니다.
--------------------------------------------------------------------------
Sub 이미지삽입0325()
Dim swidth As Single 'cell
Dim sheight As Single 'cell
mgn = 3 'margin
'path
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then
Exit Sub
Else
strPath = .SelectedItems(1) & "\"
End If
End With
Application.ScreenUpdating = False
On Error Resume Next
Set Rng = Range("A1:Z2000")
For Each pic In Rng
If Len(pic.Value) Then
picname = pic.Value & ".jpg"
Set tpic = ActiveSheet.Pictures.Insert(strPath & picname).ShapeRange 'insert
tpic.LockAspectRatio = msoTrue
tpic.Top = 1
tpic.Left = 1
tpic.Width = 120
pht = tpic.Height
tpic.Delete
'real insert (addpicture)
Set rpic = ActiveSheet.Shapes.addpicture(strPath & picname, msoFalse, msoTrue, 1, 1, 120, pht)
'change location (mergecell)
If Rng.Offset(0, 0).MergeCells Then
swidth = Rng.Offset(0, 0).MergeArea.Width
sheight = Rng.Offset(0, 0).MergeArea.Height
rpic.Height = sheight
If rpic.Width > swidth Then
rpic.Width = swidth
End If
rpic.Height = rpic.Height - (mgn * 2)
rpic.Top = Rng.Offset(0, 0).MergeArea.Top + (sheight - rpic.Height) / 2
rpic.Left = Rng.Offset(0, 0).MergeArea.Left + (swidth - rpic.Width) / 2
End If
Else
End If
Next pic
Application.ScreenUpdating = True
End Sub
==============[랄랄루라룰라님 글에 대한 답변입니다]==============
첨부파일 코드 참조하시기 바랍니다. |
|