2012-02-14 エクセルマクロ、時系列データ可視化

系列のデータをチャートにするエクセルのマクロ

logという名前のシートに、

左の列から

時間(エクセルの時間形式), ユーザid, 学年(説明はしない), 強調したいでーたにチェックしたもの

をいれといて、実行すると

resultという名前のシートにチャートを描画する

Sub logChart()
    
    'いろんな変数の準備------------------------------------------------
    
    Set myDocument = Worksheets("result") '図の書きこみ対象、空っぽのシート
    Set LogSheet = Worksheets("log(20)") '読み取り対象、ログのあるシート
    Dim rowTmp() As Double
    Dim objFeature()
    
    Dim startRow 'ログの開始行
    startRow = 6
    Dim lastRow 'ログの終了行
    lastRow = 256
    
    '基準となる幅・高さ
    BaseWidth = myDocument.Cells(1, 1).Width * 1 / 2 '幅
    BaseHeight = myDocument.Cells(1, 1).RowHeight * 1 / 2 '高さ
    

    
    '図を書き始める位置
    FirstHposition = BaseWidth * 3
    FirstVposition = BaseHeight * 3
    
   

    
    
    
    '処理開始------------------------------------------------
    result = initiateChart(myDocument, FirstHposition, FirstVposition, BaseWidth, BaseHeight) '図の軸とかを書く
    
    For rowCounter = startRow To lastRow  'ログの行を送っていくループ
        rowTmp = readLog(rowCounter, LogSheet) 'ログを読み取る
        
        objFeature = objectType(rowTmp, BaseWidth, BaseHeight) '矩形の色とか位置とかを教えてくれる
        If Not rowTmp(3) = 0 Then
            result = writeObject(myDocument, objFeature, FirstHposition, FirstVposition, BaseWidth, BaseHeight) '実際に矩形を書いていく
        End If
    Next rowCounter
   
    
     '処理終了------------------------------------------------
    
    'コネクタをシェイプを全面に出す
    
    For Each objShp In ActiveSheet.Shapes
       If objShp.Connector = True Then
           objShp.ZOrder msoBringToFront
       End If
    Next
    
End Sub


Function initiateChart(myDocument, FirstHposition, FirstVposition, BaseWidth, BaseHeight) '図の軸とかを書く
      
    '既存シェイプ全削除
    
    If myDocument.Shapes.Count > 0 Then
        myDocument.Shapes.SelectAll
        Set myShRange = Selection.ShapeRange
        myShRange.Delete
    End If
     
    'ラベルの定義
    Dim labelArray(1 To 2) As String
    labelArray(1) = "先輩"
    labelArray(2) = "後輩"
    FontSize = 10
     
    'ラベル描画
    For Counter2 = 1 To 2
        With myDocument.Shapes.AddShape(msoShapeRectangle, FirstHposition + BaseWidth * Counter2, FirstVposition - myDocument.Cells(1, 1).RowHeight, BaseWidth, myDocument.Cells(1, 1).RowHeight)
            .TextFrame.Characters.Text = labelArray(Counter2)
            .TextFrame.MarginBottom = 0
            .TextFrame.MarginLeft = 0
            .TextFrame.MarginRight = 0
            .TextFrame.MarginTop = 0
            .TextFrame.Characters.Font.Size = FontSize
            
            .TextFrame.HorizontalAlignment = xlHAlignCenter
            .TextFrame.VerticalAlignment = xlVAlignCenter
            
            .Fill.ForeColor.RGB = RGB(255, 255, 255)
            .Line.ForeColor.RGB = RGB(0, 0, 0)
            .Line.Weight = 0
            .Line.Visible = msoFalse  '線を見えなくする
            
            .TextFrame.Characters.Font.Color = RGB(0, 0, 0)  '文字色
        End With
    Next Counter2
   
   
    '日付軸描画
    For Counter3 = 0 To 6
        '横の線
        With myDocument.Shapes.AddLine(FirstHposition + BaseWidth, FirstVposition + BaseHeight * Counter3 * 7, FirstHposition + BaseWidth * 3, FirstVposition + BaseHeight * Counter3 * 7)
            .Line.ForeColor.RGB = RGB(0, 0, 0)
            .Line.Weight = 0
            .ZOrder msoSendToBack
        End With
        
        
    Next Counter3
    

End Function

Function readLog(rowCounter, LogSheet)
'ログを読み取る

    'logシートの各列が何を表わすか
    Dim indexDate
    indexDate = 1
    Dim indexUser_id
    indexUser_id = 2
    Dim indexGrade
    indexGrade = 3
    Dim indexGreeting
    indexGreeting = 4
    
    Dim rowTmp(1 To 4) As Double

    rowTmp(1) = LogSheet.Cells(rowCounter, indexDate)
    rowTmp(2) = LogSheet.Cells(rowCounter, indexUser_id)
    rowTmp(3) = LogSheet.Cells(rowCounter, indexGrade)
    rowTmp(4) = LogSheet.Cells(rowCounter, indexGreeting)
    
    readLog = rowTmp
End Function


Function objectType(rowTmp, BaseWidth, BaseHeight)  '矩形の色とか位置とかを教えてくれる
    Dim objFeature(1 To 4)
    '投稿者の学年 => 位置
    If rowTmp(3) = 1 Then
            '1年のとき
        objFeature(1) = 2 * BaseWidth
        
    ElseIf rowTmp(3) = 2 Then
        '2年のとき
        objFeature(1) = 1 * BaseWidth
    ElseIf rowTmp(3) = 0 Then
        'マネージャ
        objFeature(1) = 0
        
    End If
    
    '投稿者がサクラかどうか => 枠
    If rowTmp(2) > 400 Or rowTmp(2) < 200 Or rowTmp(2) Mod 10 = 1 Then
        objFeature(4) = 1
    Else
        objFeature(4) = 0
    End If
        
    '投稿の内容 => 色
    If rowTmp(4) = 1 Then
        objFeature(2) = RGB(160, 160, 160)
    Else
         objFeature(2) = RGB(200, 200, 200)
    End If
    
    '投稿の日時　=> 高さ
    objFeature(3) = (rowTmp(1) - 40860) * BaseHeight
    
    objectType = objFeature
End Function


Function writeObject(myDocument, objFeature, FirstHposition, FirstVposition, BaseWidth, BaseHeight) '実際に矩形を書いていく

    Set CurShape = myDocument.Shapes.AddShape(msoShapeRectangle, FirstHposition + objFeature(1), FirstVposition + objFeature(3), BaseWidth, BaseHeight * 1 / 2)  'シェイプの上端が操作日時
            With CurShape
                    '.Name = myDocument.Cells(IndexActionType, Counter).Value
                    
                    '.TextFrame.Characters.Text = ContentOfShape
                    '.TextFrame.Characters.Font.Size = 8
                    '.TextFrame.Characters.Font.Color = RGB(255, 255, 255)
                    '.TextFrame.HorizontalAlignment = xlHAlignCenter
                    
                    .TextFrame.MarginBottom = 0
                    .TextFrame.MarginLeft = 0
                    .TextFrame.MarginRight = 0
                    .TextFrame.MarginTop = 0
                    
                    .Fill.ForeColor.RGB = objFeature(2)
                    '.Fill.Visible = FillNow '塗りつぶしなし
                    
                    .Line.ForeColor.RGB = RGB(0, 0, 0)
                    If objFeature(4) = 0 Then
                        .Line.Visible = LineVisible  '線を見えなくする
                    End If
                    .Line.Weight = 0
                    
                    
                    
            End With
    
End Function