Excel VBA質問箱 IV

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

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


44027 / 76732 ←次へ | 前へ→

【37728】Re:入退出一覧表を作りたいです(結構複...
発言  ichinose  - 06/5/16(火) 23:54 -

引用なし
パスワード
   ▼rinn さん:
こんばんは。

>仕様書作成にはチャレンジしてみたいですが、どこから手をつけてどのようなものを作成すればいいかわかりませんのでそれも考え中です。
それは、rinnさんが この仕様書あるいは、マニュアルはわかりやすいと感じたものを
模倣すればよいのです。


>No イベントNo 部屋番号 入場日付 入場時間 退場日付 退場時間 料金
>1  4     1    2006/05/01  20:03 2006/05/01  21:50  \1000
>2  4     2    2006/04/30  23:00 2006/05/01  10:05  \3000
>3  4     2    2006/05/01  12:30 2006/05/01  13:10  \500
>4  5     3    2006/05/01  08:00 2006/05/01  15:40  \4500

例えば、上記のデータが新規ブックの「Sheet1」というシートの
セルA列からH列に入力されているとします。
(1行目は、項目名です)
部屋別の稼働状況は、Sheet2に作成します。
このSheet2の右側には、作業シートのSheet3があるものとします。


標準モジュールに

'============================================================
Const hh = 6 '目盛り列の巾数
'============================================================
Sub main()
  Dim idx As Long
  Dim rw As Long
  Dim svrw As Long
  Dim st As Single
  Dim wk As Double
  Dim shp As Shape
  Dim cl As Long '四角の色
  Dim eventno As Long
  Dim shpnm As String
  With ActiveSheet
    .Columns("a").ColumnWidth = 11
    .Columns("b:z").ColumnWidth = hh
    .Range("a1").Value = #5/1/2006#
    With .Range("b1:z1")
     .Formula = "=column()-2&""時"""
     .Value = .Value
     End With
    Call open_scale(2, 11, hh, .Columns("b").Width)
    With Worksheets("sheet1")
     idx = 2
     svrw = 0
     Do Until .Cells(idx, 1).Value = ""
       rw = .Cells(idx, 3).Value + 1
       wk = Application.Min(.Cells(idx, 6).Value + .Cells(idx, 7).Value, Range("a1").Value + 1) - _
             Application.Max(.Cells(idx, 4).Value + .Cells(idx, 5).Value, Range("a1").Value)
       If wk > 0 Then
        If svrw <> rw Then
          cl = 3
          svrw = rw
        Else
          cl = cl + 1
          End If
        Cells(rw, 1).Value = .Cells(idx, 3).Value
        st = (Application.Max(.Cells(idx, 4).Value + .Cells(idx, 5).Value, Range("a1").Value) _
               - Int(Application.Max(.Cells(idx, 4).Value + .Cells(idx, 5).Value, Range("a1").Value))) * 24 * hh
        Set shp = mk_rectangle(Rows(rw), st, wk * 24 * hh)
        shpnm = "shp" & idx
        eventno = .Cells(idx, 2).Value
        With shp
          .Name = shpnm
          .TextFrame.Characters.Text = "イベントNO" & eventno
          .TextFrame.HorizontalAlignment = xlHAlignCenter
          .Fill.ForeColor.SchemeColor = cl
          .Fill.Transparency = 0.75
          End With
        End If
       idx = idx + 1
       Loop
     End With
    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) 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


として、Sheet2をアクティブにした状態で

mainを実行してみて下さい。

プログラムは、2006/5/1の部屋別の稼働状況を作成します。


>それとコードの件で質問があります。
>Function mk_rectangleの中の変数「wk」と「wk2」、「ha」と「ha2」が意味するのは何でしょうか?
>オートシェイプを時間の情報から作成している箇所であるというのはわかります。またその開始位置とオートシェイプの幅などを決めているというのもわかりますが、この関数の中で色々な計算がされていてちょっと混乱しています。
>上記4つの変数がどのような意味をもって定義されているのかわかればあともう一歩ではないかなと思います。

オートシェイプの作成は、スケールとなる列の幅(上記のコードでは、hh--->6)を基準に
してポイントに変換して作成しています。

ところが、

新規ブックで以下のコード実行し見てください。


Sub test()
  Columns("a").ColumnWidth = 12
  Columns("b:c").ColumnWidth = 6
  MsgBox Range("a1").Width & "-----" & Range("b1:c1").Width
End Sub

一つの列で列幅12の列と
二つの列で列幅6の列の列の横幅の合計ポイントは上記の結果が
示すように微妙に違いますよね?

この微妙な違いを考慮にいれないと正しい位置やスケールを持った
オートシェイプの作成ができません。

上記の変数はその補正計算を行うための計算に使用しています。


以上です。

5 hits

【37596】入退出一覧表を作りたいです(結構複雑で... rinn 06/5/12(金) 17:13 質問
【37603】Re:入退出一覧表を作りたいです(結構複雑... ichinose 06/5/12(金) 18:54 発言
【37679】Re:入退出一覧表を作りたいです(結構複... rinn 06/5/15(月) 16:44 質問
【37701】Re:入退出一覧表を作りたいです(結構複... ichinose 06/5/15(月) 23:02 発言
【37715】Re:入退出一覧表を作りたいです(結構複... rinn 06/5/16(火) 13:10 質問
【37728】Re:入退出一覧表を作りたいです(結構複... ichinose 06/5/16(火) 23:54 発言
【37741】Re:入退出一覧表を作りたいです(結構複... rinn 06/5/17(水) 16:34 質問
【37743】Re:入退出一覧表を作りたいです(結構複... rinn 06/5/17(水) 16:41 発言
【37753】Re:入退出一覧表を作りたいです(結構複... ichinose 06/5/17(水) 22:34 発言
【37771】Re:入退出一覧表を作りたいです(結構複... rinn 06/5/18(木) 15:47 お礼
【37802】Re:入退出一覧表を作りたいです(結構複... ichinose 06/5/18(木) 22:06 発言
【37813】Re:入退出一覧表を作りたいです(結構複... rinn 06/5/19(金) 9:53 お礼
【37731】Re:入退出一覧表を作りたいです(結構複... ハチ 06/5/17(水) 12:27 発言
【37742】Re:入退出一覧表を作りたいです(結構複... rinn 06/5/17(水) 16:35 お礼

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