Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


9702 / 13646 ツリー ←次へ | 前へ→

【25861】タイムスケジュール(自動でセルを塗りつ... れん 05/6/16(木) 21:54 質問[未読]
【25896】Re:タイムスケジュール(自動でセルを塗り... ichinose 05/6/17(金) 14:16 発言[未読]
【25923】Re:タイムスケジュール(自動でセルを塗... れん 05/6/17(金) 22:53 お礼[未読]

【25861】タイムスケジュール(自動でセルを塗りつ...
質問  れん  - 05/6/16(木) 21:54 -

引用なし
パスワード
   こんばんは。

時間を入力した2つの表(表1、2)から、それらをまとめた一覧(表3)を作っています。
せっかく時間を入力しているので、表3に自動で入れられないでしょうか。


表1(作業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

表2(作業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


表3タイムスケジュール一覧表(表1と表2をまとめた一覧)
■作業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
│      ■■■○○   □□   ○○       │
└─────────────────────┘

【25896】Re:タイムスケジュール(自動でセルを塗...
発言  ichinose  - 05/6/17(金) 14:16 -

引用なし
パスワード
   ▼れん さん:
こんにちは。
セルの色の代わりにオートシェープを使いました。

まず・・・・、

>時間を入力した2つの表(表1、2)から、それらをまとめた一覧(表3)を作っています。
>せっかく時間を入力しているので、表3に自動で入れられないでしょうか。
>
>
この表があるシートのシート名を作業Aとします(Aは、全角大文字)。

>表1(作業Aに関する従事時間表)
>作業A
↓この見出しがA列からG列の1行目にあり、2行目からデータが入っていると
します。
>日付   作業開始時間 作業終了時間 作業開始時間 作業終了時間 会議開始 会議終了
>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とします。
他は、作業Aと同じですね!!


>表2(作業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
>
>


↓このシートをアクティブにして実行して下さい。
但し、このアクティブなシートの右にプログラムが使用する
作業シートを用意して下さい。
これがないとエラーになります。


>表3タイムスケジュール一覧表(表1と表2をまとめた一覧)
>■作業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) = "作業A" 'データ元のシート名 作業A
  shtnm(2) = "作業B" '         作業B
  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プロシジャーを実行して下さい。

試してみて下さい。

【25923】Re:タイムスケジュール(自動でセルを塗...
お礼  れん  - 05/6/17(金) 22:53 -

引用なし
パスワード
   ▼ichinose さん:
こんばんは。
ichinoseさんどうもありがとうございました。
きれいな一覧表が出来上がりました!!
まだまだ未熟なので、内容をじっくり勉強してみたいと思います(^o^)

9702 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free