Excel2000 VBA セルの数値を右側に棒グラフにして表示する実験 その3

Excel2000 VBA  セルの数値を右側に棒グラフにして表示する実験　その3

 

改良点

• オブジェクトの消し方
• バーグラフの右に数値表示
• 
  

Sub セル値でバーグラフ3()
'マクロを実行する度にオブジェクトの自動発生番号が増える
'自動発生番号のリセットが課題
'http://oshiete.goo.ne.jp/qa/3921803.html
'バーグラフの右に数値表示
Dim hani, col As Range
Dim xpos, ypos, barX, barT, barH, cell_height As Long
Dim barC, No As Integer

'xpos バーグラフを表示するセルの左からの位置
'ypos バーグラフを表示するセルの上から位置

'列範囲（バーグラフを表示する範囲）A列に数値B列にバーグラフ
    Set hani = Range("b2:b10")
'バーグラフの色
    barC = 2
'現在のバーグラフを消す
    Call bar_delete
'top、leftからの位置を調べ、バーグラフを描く
For Each col In hani
No = No + 1
    xpos = col.Left         '左からの位置
    ypos = col.top          'TOP上からの位置
    cell_height = col.Height  'セルの高さ
    'バーグラフの縦幅を決める（セル縦幅の半分）
        barH = cell_height / 2
    'バーグラフの表示セルトップから位置
        barT = barH / 2
    'バーグラフにする数値の有るセル（バーグラフの幅）
        barX = col.Offset(0, -1).Value
        If barX < 0 Then barX = 0
    'バーグラフを描く
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, xpos, ypos + barT, barX, barH).Select
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = barC
    Selection.ShapeRange.Fill.Visible = msoTrue
    Selection.ShapeRange.Fill.Solid
    'バーグラフの右に数値表示
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, xpos + barX + 4, ypos + barT, 20#, barH * 2).Select '20#は枠線なし
    Selection.Characters.Text = barX
    Selection.ShapeRange.Line.Visible = msoFalse
    With Selection.Characters(Start:=1, Length:=3).Font
        .Name = "MS UI Gothic"
        .FontStyle = "標準"
        .Size = 8.6
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        
    End With
   
    col.Offset(0, -1).Select
    'Debug.Print ActiveSheet.Shapes.Count
   
Next col


End Sub

Sub bar_delete()
'図を選択して消す方法がよくわからない
'http://oshiete.goo.ne.jp/qa/3921803.html
Dim i As Long
Dim recNO As String
On Error Resume Next
'Debug.Print ActiveSheet.Shapes.Count
'オブジェクトの自動発生番号が増えるのでカウント数では（１－カウント数）では削除できない
For i = 1 To 2000
    recNO = "Rectangle " & i
    If ActiveSheet.Shapes(recNO) Is Nothing Then GoTo nxt
    ActiveSheet.Shapes(recNO).Select
    Selection.Delete
nxt:
Next i

End Sub

タグ：Excel2000 VBA