| |
▼れん さん：
こんにちは。
セルの色の代わりにオートシェープを使いました。
まず・・・・、
>時間を入力した２つの表（表１、２）から、それらをまとめた一覧（表３）を作っています。
>せっかく時間を入力しているので、表３に自動で入れられないでしょうか。
>
>
この表があるシートのシート名を作業Ａとします（Ａは、全角大文字）。
>表１（作業Aに関する従事時間表）
>作業A
↓この見出しがＡ列からＧ列の１行目にあり、２行目からデータが入っていると
します。
>日付 作業開始時間 作業終了時間 作業開始時間 作業終了時間 会議開始 会議終了
>05/06/01 9:00 11:00 13:00 15:00 11:00 12:00
>05/06/02 9:30 11:00 13:00 14:00
>
↓この表があるシートのシート名を作業Ｂとします。
他は、作業Ａと同じですね！！
>表２（作業Bに関する従事時間表）
>作業B
>日付 作業開始時間 作業終了時間 作業開始時間 作業終了時間 会議開始 会議終了
>05/06/01 15:00 16:00 11:00 12:00
>05/06/02 11:00 12:00 15:00 16:00 13:00 14:00
>
>
↓このシートをアクティブにして実行して下さい。
但し、このアクティブなシートの右にプログラムが使用する
作業シートを用意して下さい。
これがないとエラーになります。
>表３タイムスケジュール一覧表（表１と表２をまとめた一覧）
>■作業A
>○作業B
>□会議（作業Aと作業Bの合同会議、同一時間）
>（本来はセルの色で区別）
>
>┌─────────────────────┐
>│6月1日 9 10 11 12 13 14 15 16 17 18
>│ ■■■■□□ ■■■■○○ │
>│---------------------------------------│
>│6月2日 9 10 11 12 13 14 15 16 17 18
>│ ■■■○○ □□ ○○ │
>└─────────────────────┘
では、コードです。標準モジュールに
'=====================================================================
Const hh = 8 '目盛り列の巾数
'=====================================================================
Sub main()
Dim disc
Dim shtnm(1 To 2) As String
Dim shpcl(1 To 2) As Long
shpcl(1) = 5 '色指定
shpcl(2) = 6
shtnm(1) = "作業Ａ" 'データ元のシート名 作業Ａ
shtnm(2) = "作業Ｂ" ' 作業Ｂ
disc = Array(True, False)
With ActiveSheet
.Columns("a").ColumnWidth = 11
.Columns("b:o").ColumnWidth = hh
.Range("a1").Value = "日付"
With .Range("b1:n1")
.Formula = "=column()+7"
.Value = .Value
End With
Call open_scale(2, 11, hh, .Columns("b").Width)
disc = Array(True, False)
For idx = 1 To 2
Call set_sht_data(Worksheets(shtnm(idx)), ActiveSheet, shpcl(idx), disc(idx - 1), shtnm(idx))
Next
End With
End Sub
'=====================================================================
Sub set_sht_data(insht As Worksheet, otsht As Worksheet, cl As Long, Optional kaigi As Variant = False, Optional txtstr = "")
'指定されたシート（insht）にあるタイムスケジュールデータをもとに指定されたシート（otsht）に
'タイムスケジュールをオートシェイプで作成する
' input : insht： データのあるシートオブジェクト
' cl : 作業時間の色
' kaigi : true --会議の時間を描画
' txtstr: 描画するオートシェイプに付属する文字列
' output : otsht: 作成するシートオブジェクト
Dim st As Single
Dim scl As Single
Dim shp As Shape
With insht
Set rng = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
For idx = 1 To rng.Count
otsht.Cells(idx + 1, 1).Value = rng.Cells(idx).Value
For jdx = 1 To 3 Step 2
If rng.Cells(idx).Offset(0, jdx).Value <> "" And rng.Cells(idx).Offset(0, jdx + 1).Value <> "" Then
st = (rng.Cells(idx).Offset(0, jdx).Value - TimeValue("9:00:00")) * 24 * hh
With rng.Cells(idx)
scl = (.Offset(0, jdx + 1).Value - .Offset(0, jdx).Value) * 24 * hh
End With
Set shp = mk_rectangle(otsht.Rows(idx + 1), st, scl, otsht)
shp.TextFrame.Characters.Text = txtstr
shp.TextFrame.HorizontalAlignment = xlHAlignCenter
shp.Fill.ForeColor.SchemeColor = cl
shp.Fill.Transparency = 0.75
End If
Next jdx
If kaigi = True And _
rng.Cells(idx).Offset(0, 5).Value <> "" And rng.Cells(idx).Offset(0, 6).Value <> "" Then
st = (rng.Cells(idx).Offset(0, 5).Value - TimeValue("9:00:00")) * 24 * hh
With rng.Cells(idx)
scl = (.Offset(0, 6).Value - .Offset(0, 5).Value) * 24 * hh
End With
Set shp = mk_rectangle(otsht.Rows(idx + 1), st, scl, otsht)
shp.TextFrame.Characters.Text = "会議"
shp.TextFrame.HorizontalAlignment = xlHAlignCenter
shp.Fill.ForeColor.SchemeColor = 8
shp.Fill.Transparency = 0.75
End If
Next idx
End With
End Sub
'別の標準モジュールに
'====================================================================
Private st_col As Single
Private st_point As Single
Private myscale As Single
Private sswidth As Single
'=======================================================================
Sub open_scale(開始列, 開始列までのセル巾, 目盛り巾, 目盛りPnt)
' チャート作成するシート情報を登録する
' input : 開始列 --チャート作成開始列
' 開始列までのセル巾--- 列幅の合計値
' 目盛り巾------------目盛りとなる列の列幅
' 目盛りPnt-----------目盛りとなる列のWidth
st_col = 開始列
st_point = 開始列までのセル巾
myscale = 目盛り巾
sswidth = 目盛りPnt
End Sub
'========================================================================
Function mk_rectangle(rng As Range, 開始 As Single, 巾 As Single, Optional sht As Worksheet = Nothing, Optional txtstr = "") As Shape
'指定された行に開始位置，巾の情報から、チャートを作成する
'input : rng---作成する行を表すRangeオブジェクト
' 開始---チャート作成開始位置を開始列からの列幅単位で指定
' 巾-----チャート作成巾を列幅単位で指定
' sht----チャートを作成するシートオブジェクト 尚、このシートの右のシートは作業シートとして
' 使用します。
' txtstr----チャートに記述する文字列
'output : mk_rectangle----作成したShapeオブジェクト
Dim mkleft As Single
Dim mkwidth As Single
If sht Is Nothing Then Set sht = ActiveSheet
wk = Int(開始 / myscale) * myscale
wk2 = (開始 - wk) / myscale
ha = Int(巾 / myscale) * myscale
ha2 = (巾 - ha) / myscale
cnv_left = get_point(wk + st_point, sht.Next)
cnv_width = get_point(ha, sht.Next)
If wk2 = 0 Then
mkleft = cnv_left + 3.75 * (st_col - 1 + Int((開始 - 0.1) / myscale))
Else
mkleft = cnv_left + 3.75 * (st_col - 1 + Int((wk - 0.1) / myscale)) + sswidth * wk2
End If
If ha2 = 0 Then
If ha = 0 Then
mkwidth = cnv_width
Else
mkwidth = cnv_width + 3.75 * Int((ha - 0.1) / myscale)
End If
Else
If ha = 0 Then
mkwidth = cnv_width + sswidth * ha2
Else
mkwidth = cnv_width + 3.75 * Int((ha - 0.1) / myscale) + sswidth * ha2
End If
End If
With rng
Set mk_rectangle = sht.Shapes.AddShape(msoShapeRectangle, mkleft, .Top, mkwidth, .Height)
End With
End Function
'=========================================================================
Function get_point(セル幅, sht As Worksheet)
With sht
.Cells(1, 1).ColumnWidth = セル幅
get_point = IIf(.Cells(1, 1).Width <= 0, 0, .Cells(1, 1).Width)
End With
End Function
チャートを作成するシート（真っ白なシートでよいです）を
アクティブにして（右に作業シートの作成を忘れずに）
mainプロシジャーを実行して下さい。
試してみて下さい。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
