[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ガントチャートに時刻を追加』（ﾃｾｳｽの船）
ネットで見つけたのですがオートシェイプを使ってガントチャートを描画するマクロです。 開始日や日数を入力すると、色付きの四角形を自動的に表示します。 時刻を持たせて双方向の矢印を四角形上に表示出来たら最高なのですが・・・ 教えていただきたい。宜しくお願いします。
' 「開始日」(3,4) セルD3
' 「DayStart」(4,10) セルJ4 ' バーの開始セル (6,10) セルJ6 ' バーの書式参照先 B列 (0,2)
'Public Const StartClm As Integer = 10 ' old「DayStart」(4,10) セルJ4 'Public Const StartDayClm As Integer = 4 ' old 'Public Const StartRow As Integer = 6
Public StartClm As Integer ' 「DayStart」(4,10) セルJ4 Public StartDayClm As Integer Public StartRow As Integer
Public Const DateDifClm As Integer = 5 Public Const ColorClm As Integer = 2
Public lngShapeStyle As Long ' 図形スタイル Public lngLineColor As Long ' 図形の枠線の色 Public lngLineWeight As Long ' 図形の枠線の太さ
Public strItem As String ' 項目名の表示
Sub 一括作成1()
' 初期設定
With ActiveSheet
StartClm = .Range("DayStart").Column ' 10 old「DayStart」(4,10) セルJ4
StartDayClm = 4 ' 4
StartRow = .Range("DayStart").Row + 2 ' 6
End With
' n日の場合のみ
Dim lngIntervalDays As Long ' 間隔がある場合の間隔日数
Dim lngStartRow As Long Dim lngRowsCnt As Long Dim i As Long
lngStartRow = ActiveSheet.ListObjects(1).HeaderRowRange.Row lngRowsCnt = ActiveSheet.ListObjects(1).DataBodyRange.Rows.Count
Application.ScreenUpdating = False For i = lngStartRow + 1 To lngStartRow + lngRowsCnt
Call 行図形クリア(i)
Call 図形(i, 1)
Next i Application.ScreenUpdating = True
End Sub
Sub 一括作成n()
' 初期設定
With ActiveSheet
StartClm = .Range("DayStart").Column ' 10 old「DayStart」(4,10) セルJ4
StartDayClm = 4 ' 4
StartRow = .Range("DayStart").Row + 2 ' 6
End With
' n日の場合のみ
Dim lngIntervalDays As Long ' 間隔がある場合の間隔日数
lngIntervalDays = ActiveSheet.Range("間隔日数").Value
Dim lngStartRow As Long Dim lngRowsCnt As Long Dim i As Long
lngStartRow = ActiveSheet.ListObjects(1).HeaderRowRange.Row lngRowsCnt = ActiveSheet.ListObjects(1).DataBodyRange.Rows.Count
Application.ScreenUpdating = False For i = lngStartRow + 1 To lngStartRow + lngRowsCnt
Call 行図形クリア(i)
Call 図形(i, lngIntervalDays)
Next i Application.ScreenUpdating = True
End Sub
Sub 罫線1()
Application.ScreenUpdating = False Call 罫線描画(1) Application.ScreenUpdating = True
End Sub
Sub 罫線n()
' n日の場合のみ
Dim lngIntervalDays As Long ' 間隔がある場合の間隔日数
lngIntervalDays = ActiveSheet.Range("間隔日数").Value
Application.ScreenUpdating = False Call 罫線描画(lngIntervalDays) Application.ScreenUpdating = True
End Sub
Sub クリア()
'オートシェイプのみクリア Dim objShp As Shape
Application.ScreenUpdating = False
For Each objShp In ActiveSheet.Shapes
If objShp.Type = msoAutoShape _
Or objShp.Type = msoTextBox Then
objShp.Delete
End If
Next objShp
'Or objShp.Type = msoPicture
Application.ScreenUpdating = True
End Sub
Sub Tbl2_Clear()
'テーブルの2行目以降のデータをクリアする 'テーブル内を選択して[Ctrl]+[t] Dim rngSelect As Range '選択している範囲 Dim strTlb As String '選択しているテーブル名
'エラーチェック---------------------------------------------------------
If TypeName(Selection) = "Range" Then
Set rngSelect = Selection
Else
MsgBox "テーブル内にあるセルを選択して、再実行してください。"
Exit Sub
End If
Application.ScreenUpdating = False
On Error GoTo errorPrc
strTlb = rngSelect.ListObject.Name ' セル番地からテーブル名を取得する
'テーブルの2行目以降をクリア--------------------------------------------
With ActiveSheet.ListObjects(strTlb)
If .ListRows.Count > 1 Then
.DataBodyRange.Offset(1, 0).Resize(.ListRows.Count - 1, .ListColumns.Count).Clear '2行目以降をクリア
.Resize Range:=.HeaderRowRange.Resize(2, .ListColumns.Count) 'データ1行
End If
End With
Set rngSelect = Nothing
Exit Sub
'テーブル名を取得できない場合のエラー処理-----------------------------
errorPrc:
MsgBox "テーブル内にあるセルを選択して、再実行してください。"
Application.ScreenUpdating = True
End Sub
Sub 行図形クリア(lngRow As Long)
With ActiveSheet
'クリア------四角形 1 のみをクリアする
On Error Resume Next
If .Shapes(CStr(lngRow)).AutoShapeType = 1 Then .Shapes(CStr(lngRow)).Delete
If .Shapes(CStr(lngRow) & "始点").AutoShapeType = 1 Then .Shapes(CStr(lngRow) & "始点").Delete
If .Shapes(CStr(lngRow) & "終点").AutoShapeType = 1 Then .Shapes(CStr(lngRow) & "終点").Delete
On Error GoTo 0
End With
End Sub
Sub 図形(lngRow As Long, lngIntervalDays As Long)
Dim StartDay As Long Dim lngDateDif As Long Dim intClm As Integer Dim Square As Shape Dim SqrLeft As Long, SqrTop As Long Dim SqrWidth As Long, SqrHeight As Long Dim lngFontClr As Long ' フォントの色 Dim strItemNave As String Dim strBar As String ' バー内の表示文字列
strItem = Worksheets("環境設定").Range("項目名").Value
With ActiveSheet
' 開始日のデータ型エラー処理
If Not IsDate(Range("開始日").Value) Then
MsgBox Prompt:="開始日が日付ではありません。", _
Buttons:=vbCritical, _
Title:="開始日エラー"
End
End If
StartDay = CLng(.Cells(lngRow, StartDayClm).Value) - CLng(Range("開始日").Value)
' 開始日の日付エラー処理
If StartDay < 0 Then
MsgBox Prompt:="チャートの開始日より前の日付になっています。", _
Buttons:=vbCritical, _
Title:="開始日エラー"
End
'※ n日のみ
ElseIf lngIntervalDays > 1 And StartDay > Range("期間") * lngIntervalDays Then
MsgBox Prompt:="チャートの最終日より後の日付になっています。", _
Buttons:=vbCritical, _
Title:="開始日エラー"
End
End If
' バー内の表示の設定 なし,バー内側-左,バー内側-右,終了日-右
lngDateDif = .Cells(lngRow, DateDifClm).Value
strItemNave = .Cells(lngRow, DateDifClm - 2).Value
Select Case strItem
Case "なし", "終了日-右"
strBar = lngDateDif
Case "バー内側-左"
strBar = strItemNave & " " & lngDateDif
Case "バー内側-右"
strBar = lngDateDif & " " & strItemNave
Case Else
MsgBox "項目名の表示の設定がされていません。"
End Select
'四角形の表示-----------------
'※ n日のみ
'MsgBox StartDay & " " & StartClm '※ n日のみ
If lngIntervalDays > 1 Then
StartDay = Int(StartDay / lngIntervalDays) '※ n日のみ
End If
With .Cells(lngRow, StartDay + StartClm)
SqrLeft = .Left + 0.5
SqrTop = .Top + 3
SqrHeight = .Height - 6
End With
With .Range(.Cells(lngRow, StartDay + StartClm) _
, .Cells(lngRow, StartDay + StartClm + lngDateDif - 1))
SqrWidth = .Width - 1
End With
Set Square = .Shapes.AddShape _
(msoShapeRectangle, SqrLeft, SqrTop, SqrWidth, SqrHeight)
'図形の名前の設定
Square.Name = lngRow
'図形の色の設定
Square.Fill.ForeColor.RGB = .Cells(lngRow, ColorClm).Interior.Color
'図形の文字の設定
lngFontClr = .Cells(lngRow, ColorClm).Font.Color
With Square.TextFrame
.Characters.Text = strBar
.Characters.Font.Color = lngFontClr
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
' バーの枠線の色などの設定
If lngShapeStyle <> 0 Then
Square.ShapeStyle = lngShapeStyle
Else
Square.Line.ForeColor.RGB = lngLineColor
Square.Line.Weight = lngLineWeight / 100
End If
Set Square = Nothing
'始点テキストボックスの表示-----------------
With .Cells(lngRow, StartDay + StartClm - 3)
SqrLeft = .Left + 1
SqrTop = .Top + 3.5
SqrHeight = .Height - 6
End With
With .Range(.Cells(lngRow, StartDay + StartClm - 3) _
, .Cells(lngRow, StartDay + StartClm - 1))
SqrWidth = .Width - 3
End With
Set Square = .Shapes.AddTextbox _
(msoTextOrientationHorizontal, SqrLeft, SqrTop, SqrWidth, SqrHeight)
'図形の名前の設定
Square.Name = lngRow & "始点"
Square.Line.Visible = msoFalse
With Square.TextFrame
.Characters.Text _
= Format(ActiveSheet.Cells(lngRow, StartDayClm), "m/d")
.Characters.Font.Size = 10
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
End With
Set Square = Nothing
'終点テキストボックスの表示-----------------
With .Cells(lngRow, StartDay + StartClm + lngDateDif + 0)
SqrLeft = .Left + 1
SqrTop = .Top + 3.5
SqrHeight = .Height - 6
End With
With .Range(.Cells(lngRow, StartDay + StartClm + lngDateDif + 0) _
, .Cells(lngRow, StartDay + StartClm + lngDateDif + 2))
If strItem = "終了日-右" Then
SqrWidth = .Width + Len(strItemNave) * 8
Else
SqrWidth = .Width - 3
End If
End With
Set Square = .Shapes.AddTextbox _
(msoTextOrientationHorizontal, SqrLeft, SqrTop, SqrWidth, SqrHeight)
'図形の名前の設定
Square.Name = lngRow & "終点"
Square.Line.Visible = msoFalse
With Square.TextFrame
If strItem = "終了日-右" Then
.Characters.Text _
= Format(ActiveSheet.Cells(lngRow, StartDayClm + 2), "m/d") & " " & strItemNave
Else
.Characters.Text _
= Format(ActiveSheet.Cells(lngRow, StartDayClm + 2), "m/d")
End If
.Characters.Font.Size = 10
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
Set Square = Nothing
End With
End Sub
Sub 罫線描画(lngIntervalDays As Long)
' 罫線を引く
' 初期設定
With ActiveSheet
StartClm = .Range("DayStart").Column ' 10 old「DayStart」(4,10) セルJ4
StartDayClm = 4 ' 4
StartRow = .Range("DayStart").Row + 2 ' 6
End With
Dim lngRowsCnt As Long
lngRowsCnt = ActiveSheet.ListObjects(1).DataBodyRange.Rows.Count
' 罫線を引く
If IsDate(Range("開始日")) And Range("期間").Value >= 1 Then
Call 日付クリア
Call 日付(lngIntervalDays)
'※ 月の罫線 ver2.04
If Range("月表示") = "表示する" Then
Call 罫線(Range(Range("DayStart").Offset(-1, 0), Range("DayStart").End(xlToRight).Offset(0, 0)))
End If
'日付の罫線 ver2 余分な領域に線を引かないように、currentregionからの変更した
Call 罫線(Range(Range("DayStart"), Range("DayStart").End(xlToRight).Offset(1, 0)))
'G列の罫線
Call 罫線(Range(Range("DayStart").Offset(1, -3) _
, Cells(StartRow + lngRowsCnt - 1, StartClm - 1)))
'バーをプロットする範囲の罫線
Call 罫線(Range(Cells(StartRow, StartClm) _
, Cells(StartRow + lngRowsCnt - 1, StartClm + Range("期間").Value - 1)))
'※ ver2 「-1」 ver1 「-6」は非表示の行 6～10 の分だけ引く
End If
End Sub
Sub 日付クリア()
With ActiveSheet.UsedRange
Range(Range("DayStart").Offset(-1, -3), .Cells(.Count)).Clear
End With
End Sub
Sub 日付(lngInterval As Long)
Dim lngDayCnt As Long
Dim i As Long
Dim lngColumnCnt As Long
Dim strYoubi As String
Dim intMonth As Integer
lngDayCnt = Range("期間").Value - 1
lngColumnCnt = 0
intMonth = Month(Range("開始日").Value)
For i = 0 To lngDayCnt * lngInterval Step lngInterval
If Range("月表示") = "表示する" And _
(intMonth <> Month(Range("開始日").Value + i) Or i = 0) Then
Range("DayStart").Offset(-1, lngColumnCnt).Value _
= Month(Range("開始日").Value + i)
intMonth = Month(Range("開始日").Value + i)
End If
Range("DayStart").Offset(0, lngColumnCnt).Value _
= Day(Range("開始日").Value + i)
strYoubi = WeekdayName(Weekday(Range("開始日").Value + i), True)
'strYoubi = Format(Range("開始日").Value + i, "aaa")
Range("DayStart").Offset(1, lngColumnCnt).Value _
= strYoubi
Select Case strYoubi
Case "土"
Call 土日表示(Range("DayStart").Offset(0, lngColumnCnt).Cells(1.1), 5)
Case "日"
Call 土日表示(Range("DayStart").Offset(0, lngColumnCnt).Cells(1.1), 3)
End Select
lngColumnCnt = lngColumnCnt + 1
Next i
With Range(Range("DayStart").Offset(-1, 0), Range("DayStart").Offset(1, lngDayCnt))
With .Font
.Size = 10
.Name = "Arial"
End With
.ShrinkToFit = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End Sub
Sub 土日表示(upCell As Range, lngColor As Long)
With upCell.Resize(2, 1)
.Font.ColorIndex = lngColor
End With
End Sub
Sub 罫線(BordRng As Range)
With BordRng
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = 1
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1 '.ColorIndex = 4
End With
.BorderAround LineStyle:=xlContinuous, Weight:=xlThin, ColorIndex:=1
', ColorIndex:=9
End With
End Sub
Sub セル高変更(StartRow As Integer, intRowCnt As Integer, lngHeight As Long)
With ActiveSheet
.Rows(StartRow + intRowCnt).RowHeight = lngHeight
End With
End Sub
Sub セル幅変更(StartClm As Integer, intClmCnt As Integer, lngWidth As Long)
With ActiveSheet
.Columns(StartClm + intClmCnt).ColumnWidth = _
lngWidth / .Columns(StartClm + intClmCnt).Width _
* .Columns(StartClm + intClmCnt).ColumnWidth
End With
End Sub
＜ 使用 Excel：Excel2013、使用 OS：Windows8 ＞
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.