あらきけいすけの雑記帳

2013-01-27 (Sun)

[]Excelで1枚のグラフに複数のデータの散布図を描くVBAマクロ

f:id:arakik10:20130127094407j:image

上図のA列をY軸方向、B, C, D, E列をX軸方向のデータとして1枚のグラフに4本の散布図をプロットする最小限のコード。軸の設定とかは書いていない。複数データの散布図を同時に1枚のグラフの上に描く方法の解説が意外にウェブ上に無かったのでメモ。手許の環境は Windows 7 + Office 2010 のデフォルト設定。こんなものいちいち覚えてられない。

Option Explicit
Sub drawMultipleXYScatterGraph()
    Dim i As Integer, iColumn As Integer
    Dim iRowStart As Integer, iRowEnd As Integer, iRowOffset As Integer
    Dim r As Range
    Set r = ThisWorkbook.ActiveSheet.Range("A1") ' セル位置計算の起点の設定
    With ActiveSheet.ChartObjects.Add(10, 10, 360, 270).Chart
        .ChartType = xlXYScatterLines
            ' ↑Excel2010の [挿入]=>[グラフ]=>[散布図] に相当する。
        iRowOffset = 1
        For i = 1 To 4
            iRowStart = 1 + iRowOffset
            iRowEnd = 10 + iRowOffset
            iColumn = i + 1
            .SeriesCollection.NewSeries 'Excel:系列の設定、自動で1から系列番号が振られる
                ' ↑Excel2010の [グラフツール]=>[デザイン]=>[データの選択]
                '    =>[データソースの選択]ウィザード=>[追加(A)] に相当する
            With .SeriesCollection(i)
                ' ↑Excel2010の [グラフツール]=>[デザイン]=>[データの選択]
                '    =>[データソースの選択]ウィザード=>[系列i] に相当する
                .Name = Range(r.Cells(iRowOffset, iColumn), r.Cells(iRowOffset, iColumn))
                .Values = Range(r.Cells(iRowStart, 1), r.Cells(iRowEnd, 1))
                .XValues = Range(r.Cells(iRowStart, iColumn), r.Cells(iRowEnd, iColumn))
            End With
        Next i
    End With
End Sub

[]Excelで枠線で囲まれたセルの範囲を取得する VBA Function

f:id:arakik10:20130127090541j:image

Excelで上図のように矩形の枠線で囲まれたセルの範囲(Rangeオブジェクト)を取得するVBAのFunctionを作成したのでメモ。Excelでセルの結合はなされていないが、枠線で囲まれているので「一つの項目」として扱われている対象を取り出すために作成してみた。上図のサンプルに対するこのコードの出力はメッセージボックスに "0 $B$2:$D$8"と表示される。

Option Explicit

Sub test02()
    Dim s As Worksheet
    Dim rRoot As Range, rRange As Range
    Dim sLeftTop As String, sRightBottom As String, c
    Dim flagError As Integer
    Set s = ThisWorkbook.Worksheets("Sheet1")
    Set rRoot = s.Range("B4")
    Set rRange = s.Range("A1:D8")
    MsgBox flagError & vbNewLine & seekRangeRectangularBorders(rRoot, rRange, flagError).Address
End Sub

Function seekRangeRectangularBorders( _
    ByVal rSeekRoot As Range, ByVal rSeekRange As Range, ByRef flagError As Integer _
) As Range
    '
    ' 矩形の枠線に囲まれた Range を求める。
    '
    ' 入力
    '   rSeekRoot As Range 探索の起点(複数セルを含むとき、左上隅セルが起点になる)
    '   rSeekRange As Range 探索の範囲
    '   flagError As Integer [探索に成功(失敗がない)]0,
    '     [失敗:起点が探索範囲外]1, [失敗:探索中に範囲外に出た]2
    '
    ' 戻り値
    '   [探索に成功]枠で囲まれたRange
    '   [失敗]起点のRange
    '
    Dim iColumn As Integer, iColumnMax As Integer, iColumnMin As Integer
    Dim iRow As Integer, iRowMin As Integer, iRowMax As Integer
    Dim iRColumnMax As Integer, iRColumnMin As Integer
    Dim iRRowMin As Integer, iRRowMax As Integer
    Dim rBuf As Range
    If rSeekRoot = Application.Intersect(rSeekRoot, rSeekRange) Then ' 探索範囲と起点の重なりチェック
        iColumnMin = 1: iRowMin = 1:
        iColumnMax = 1: iRowMax = 1:
        iRColumnMin = rSeekRange.Cells(1, 1).Column - rSeekRoot.Cells(1, 1).Column + 1
        iRColumnMax = rSeekRange.Cells(1, rSeekRange.Columns.Count).Column _
            - rSeekRoot.Cells(1, 1).Column + 1
        iRRowMin = rSeekRange.Cells(1, 1).Row - rSeekRoot.Cells(1, 1).Row + 1
        iRRowMax = rSeekRange.Cells(rSeekRange.Rows.Count, 1).Row - rSeekRoot.Cells(1, 1).Row + 1
        '
        ' 枠線の探索ループ:
        '
        Do
            Set rBuf = Range(rSeekRoot.Cells(iRowMin, iColumnMin), rSeekRoot.Cells(iRowMax, iColumnMax))
            If rBuf.Borders(xlEdgeTop).LineStyle = -4142 Then iRowMin = iRowMin - 1
            If rBuf.Borders(xlEdgeLeft).LineStyle = -4142 Then iColumnMin = iColumnMin - 1
            If rBuf.Borders(xlEdgeBottom).LineStyle = -4142 Then iRowMax = iRowMax + 1
            If rBuf.Borders(xlEdgeRight).LineStyle = -4142 Then iColumnMax = iColumnMax + 1
            '
            ' 探索範囲内チェック
            '
            If iRowMin < iRRowMin Or iRowMax > iRRowMax _
            Or iColumnMin < iRColumnMin Or iColumnMax > iRColumnMax Then
                flagError = 2
                Set seekRangeRectangularBorders = rSeekRoot
                Exit Function
            End If
        Loop While rBuf.Address <> _
        Range(rSeekRoot.Cells(iRowMin, iColumnMin), rSeekRoot.Cells(iRowMax, iColumnMax)).Address
        flagError = 0
        Set seekRangeRectangularBorders = rBuf
    Else
        flagError = 1
        Set seekRangeRectangularBorders = rSeekRoot
    End If
End Function