본문 바로가기

비즈

PPM 을 위한 Excel 거품차트 만들기 매크로

엑셀 데이터 분석 대사전이란 책의 부록에 있는 Macro 를 옮긴 것이다.
PPM을 이용한 전략을 짜기 위해서 사용했었다.

엑셀 데이터 분석 대사전
Mitsutaks Samejima.Yuji Terada 지음, 윤신례 옮김/영진.com

Sub 거품차트()

    Const GrphRngStr As String = "F3:L20"
    Const GrphTtlRngStr As String = "A1"
    Const BrdClr As Integer = 11
    Dim GrphSucStr As String
    Dim LastRow As Long
    Dim PntObj As Point
    Dim i As Integer
   

    LastRow = Range("B65536").End(xlUp).Row
    GrphTitleStr = ActiveSheet.Range(GrphTtlRngStr).Value

    GrphSucStr = "B4:D" & LastRow
  
    With ActiveSheet.ChartObjects.Add(Left:=Range(GrphRngStr).Left, _
                                Top:=Range(GrphRngStr).Top, _
                                Width:=Range(GrphRngStr).Width, _
                                Height:=Range(GrphRngStr).Height) _
                                .Chart
                               
        .SetSourceData Source:=Range(GrphSucStr), PlotBy:=xlColumns
        .ChartType = xlBubble3DEffect
       
        .SeriesCollection.NewSeries
        .SeriesCollection(1).XValues = Range("B4:B" & LastRow)
        .SeriesCollection(1).Values = Range("C4:C" & LastRow)
        .SeriesCollection(1).BubbleSizes = _
            "=" & Range("D4:D" & LastRow).Address(ReferenceStyle:=xlR1C1, External:=True)

        .SeriesCollection(3).Delete
        .SeriesCollection(2).Delete
   

        .HasTitle = True
        .ChartTitle.Text = GrphTitleStr
       
        .HasLegend = False
       
        .ChartGroups(1).VaryByCategories = True
       


        .Axes(xlCategory) _
                .TickLabelPosition = xlTickLabelPositionLow
        .Axes(xlValue) _
                .TickLabelPosition = xlTickLabelPositionLow


        With .Axes(xlValue)

            .CrossesAt = (.MinimumScale + .MaximumScale) / 2
            .MajorTickMark = xlCross
       
            With .Border
                .ColorIndex = BrdClr
                .Weight = xlMedium
                .LineStyle = xlContinuous
            End With
   
        End With
   
        With .Axes(xlCategory)
       
            .CrossesAt = (.MinimumScale + .MaximumScale) / 2
            .MajorTickMark = xlCross

            With .Border
                .ColorIndex = BrdClr
                .Weight = xlMedium
                .LineStyle = xlContinuous
            End With
   
        End With

    End With


    i = 1
       
    With ActiveSheet
        .ChartObjects(.ChartObjects.Count).Activate
    End With
   
    ActiveChart.ApplyDataLabels
       
    With Range("A4:A" & LastRow)
   
        For Each PntObj In ActiveChart.SeriesCollection(1).Points
       
            PntObj.DataLabel.Text = .Cells(i).Value
           
            i = i + 1
           
        Next PntObj
       
        Set PntObj = Nothing
       
    End With
   
    ActiveSheet.Range("G6").Activate
   
End Sub

Sub 항목명이동()
    Dim PntObj As Point
    Dim LftMove As Single

이동거리입력:

    LftMove = Application.InputBox( _
                Prompt:="왼쪽으로 이동할 항목명의 거리를 입력해주세요" & vbCrLf & _
                "(포인트 단위) +의 값은 왼쪽에, -값은 오른쪽으로 항목명이; 이동합니다. ", _
                Title:="항목명의 이동 거리 입력", _
                Type:=1)
    
    If LftMove = False Then
        Exit Sub
    End If
     
    With ActiveSheet
        .ChartObjects(.ChartObjects.Count).Activate
    End With
       
    ActiveChart.ApplyDataLabels
       
    For Each PntObj In ActiveChart.SeriesCollection(1).Points
        With PntObj.DataLabel
               
            If LftMove > .Left Then
                MsgBox "값이 넘어가지 않도록 다시 입력하세요"
                GoTo 이동거리입력
            Else
                .Left = .Left - LftMove
            End If
           
        End With
       
    Next PntObj
       
    Set PntObj = Nothing
   
    ActiveSheet.Range("G6").Activate
   
End Sub