[VBA매크로] 폴더내에 그림파일명과 일치 하는 사진(그림) 넣기 질문요...
-
게시물 수정 , 삭제는 로그인 필요
저는 참조된 파일명에 맞는 사진을 바로 위 병합된 셀에 넣고 싶습니다ㅠ
어떻게 수정해야 할지를 모르겠네요ㅠ
제가 따라해본 아래에 VBA매크로입니다.
출처:https://blog.naver.com/rosa0189/60156371664
Option Explicit
Sub insert_Pictures_Matching_Name()
Dim fileName As String '각 파일 이름을 넣을 변수
Dim strPath As String '폴더의 경로를 넣을 변수
Dim C As Range '검색에 일치한 셀을 넣을 변수
Dim strName As String '파일 확장자 제외한 이름을 넣을 변수
Application.ScreenUpdating = False '화면 업데이트 (일시) 정지
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 <> "" '이름이 없지 않다면, 즉, 파일이 존재하면
strName = Split(fileName, ".")(0) '파일 확장자 제거한 이름 추출
Set C = ActiveSheet.UsedRange.Find(strName, , , xlWhole) '그림파일과 일치하는 셀을 찾음
If Not C Is Nothing Then '그림파일과 동일한 이름이 셀에 존재하면
ActiveSheet.Pictures.Insert(strPath & fileName).Select '각 그림파일 삽입
Set C = C.Next.MergeArea '셀병합 셀을 C에 넣음
With Selection'선택된 그림파일
.Name = "Temp"'복사된 사진의 이름을 변경
.ShapeRange.LockAspectRatio = msoFalse '그림의 가로/세로비율 고정 해제
.Height = C.Height - 4 '그림의 가로크기 지정
.Width = C.Width - 4 '그림의 세로크기 지정
.Copy'그림을 복사
ActiveSheet.PasteSpecial Link:=False
'그림 링크깨고 붙여넣기
ActiveSheet.Pictures("Temp").Delete '원본 그림파일 삭제
End With
With Selection'(복사되어)선택된 그림파일
.Left = C.Left + 2'그림의 왼쪽위치 지정
.Top = C.Top + 2 '그림의 윗쪽위치 지정
End With
End If
fileName =Dir'다음 파일을 파일이름에 넣음
Loop'무한 반복
End Sub
저는 참조된 파일명에 맞는 사진을 바로 위 병합된 셀에 넣고 싶습니다ㅠ
어떻게 수정해야 할지를 모르겠네요ㅠ
제가 따라해본 아래에 VBA매크로입니다.
출처:https://blog.naver.com/rosa0189/60156371664
Option Explicit
Sub insert_Pictures_Matching_Name()
Dim fileName As String '각 파일 이름을 넣을 변수
Dim strPath As String '폴더의 경로를 넣을 변수
Dim C As Range '검색에 일치한 셀을 넣을 변수
Dim strName As String '파일 확장자 제외한 이름을 넣을 변수
Application.ScreenUpdating = False '화면 업데이트 (일시) 정지
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 <> "" '이름이 없지 않다면, 즉, 파일이 존재하면
strName = Split(fileName, ".")(0) '파일 확장자 제거한 이름 추출
Set C = ActiveSheet.UsedRange.Find(strName, , , xlWhole) '그림파일과 일치하는 셀을 찾음
If Not C Is Nothing Then '그림파일과 동일한 이름이 셀에 존재하면
ActiveSheet.Pictures.Insert(strPath & fileName).Select '각 그림파일 삽입
Set C = C.Next.MergeArea '셀병합 셀을 C에 넣음
With Selection'선택된 그림파일
.Name = "Temp"'복사된 사진의 이름을 변경
.ShapeRange.LockAspectRatio = msoFalse '그림의 가로/세로비율 고정 해제
.Height = C.Height - 4 '그림의 가로크기 지정
.Width = C.Width - 4 '그림의 세로크기 지정
.Copy'그림을 복사
ActiveSheet.PasteSpecial Link:=False
'그림 링크깨고 붙여넣기
ActiveSheet.Pictures("Temp").Delete '원본 그림파일 삭제
End With
With Selection'(복사되어)선택된 그림파일
.Left = C.Left + 2'그림의 왼쪽위치 지정
.Top = C.Top + 2 '그림의 윗쪽위치 지정
End With
End If
fileName =Dir'다음 파일을 파일이름에 넣음
Loop'무한 반복
End Sub
