엑셀 지도 차트 만들기, 오류 없이 쉽고 빠르게 만드는 방법

'---------- 2024년 8월, M365 기준 클립보드 오류를 수정한 버전입니다 ---------------
#If VBA7 Then
    Private Declare PtrSafe Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As Office.IAccessible, _
    ByVal iChildStart As Long, ByVal cChildren As Long, _
    ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
    Public Const myVBA7 As Long = 1
#Else
    Private Declare Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As Office.IAccessible, _
                                                              ByVal iChildStart As Long, ByVal cChildren As Long, _
                                                              ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
    Public Const myVBA7 As Long = 0
#End If
 
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
 
Sub ClearClipboard()
    ' 클립보드 열기
    If OpenClipboard(0&) Then
        ' 클립보드 비우기
        EmptyClipboard
        ' 클립보드 닫기
        CloseClipboard
    End If
End Sub
 
Sub CreateLinkedImage()
 
Dim rng As Range
Dim WS As Worksheet
Dim sFormula As String
Dim pic As Shape
Dim j As Long: j = 1
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
 
Set WS = ActiveSheet
Set rng = WS.Range("B2").CurrentRegion '<- 연결된 이미지를 생성할 데이터가 시작되는 셀 주소를 입력하세요
 
With WS
    For i = rng.Column To rng.Column + rng.Columns.Count - 1
    .Range(.Cells(rng.Row, i), .Cells(rng.Row + rng.Rows.Count - 1, i)).Copy
    .Cells(rng.Row + rng.Rows.Count + 1, i).Select
    .Pictures.Paste Link:=True
    Set pic = WS.Shapes(j): j = j + 1
    Application.CutCopyMode = False
    ClearClipboard
    EvRClearOfficeClipBoard
 
    sFormula = pic.DrawingObject.Formula
    .Shapes.Range(Array(pic.Name)).Select
    Selection.Formula = "='" & WS.Name & "'!" & Trim(sFormula)
    Next
End With
 
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
 
End Sub
 
Public Sub EvRClearOfficeClipBoard()
 
    Dim cmnB, IsVis As Boolean, j As Long, Arr As Variant
    Arr = Array(4, 7, 2, 0)                      '4 and 2 for 32 bit, 7 and 0 for 64 bit
    Set cmnB = Application.CommandBars("Office Clipboard")
    IsVis = cmnB.Visible
    On Error Resume Next
    If Not IsVis Then
        cmnB.Visible = True
        DoEvents
    End If
 
    For j = 1 To Arr(0 + myVBA7)
        AccessibleChildren cmnB, Choose(j, 0, 3, 0, 3, 0, 3, 1), 1, cmnB, 1
    Next
 
    cmnB.accDoDefaultAction CLng(Arr(2 + myVBA7))
 
    Application.CommandBars("Office Clipboard").Visible = IsVis
 
End Sub