[[20151022120404]] 『一日の作業工程をガンチャート表示にしたい-3』(yuri) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『一日の作業工程をガンチャート表示にしたい-3』(yuri)

 以前から、お世話になっております。
工程表の一部変更に伴い、また分からない事がありますので、改めてスレットを立てて質問させて下さい。
旧スレッド[[20131109131120]]

 以前より、ichinose様には、最後まで細かくご教示頂き感謝しております。
さて、今回の質問ですが、オートシェープ内の色設定についてです。

下記が今使用中のコードです。

  Sub 新ガントチャート()

    Const ss = 9
    Dim hh As Single                                    
    Dim idx As Long                                     
    Dim rw As Long                                      
    Dim row1 As Long
    Dim mkrw As Long
    Dim col As Long
    Dim carray As Variant                               
    Dim sumwidth As Single
    Dim sht As Worksheet
    Dim dstr As String
    Dim 完了予定 As Date
    Dim dic As Object
    Set dic = CreateObject("scripting.dictionary")
    Set sht = Worksheets("進捗管理")

    With sht
       row1 = .Cells(.Rows.Count, "i").End(xlUp).Row                    

  End With
    With Worksheets("作業チャート表")
       On Error Resume Next
         .DrawingObjects.Delete
         .Columns("a:a").ClearContents
         .Range("F7").Value = "1"

       On Error GoTo 0                                                  
         .Columns("a").ColumnWidth = 16                                  
         .Columns("b").ColumnWidth = 14                                
         .Columns("c:h").ColumnWidth = 8                               
         .Columns("i:dr").ColumnWidth = 13                          

       For idx = 1 To ss - 1
          sumwidth = sumwidth + .Columns(idx).ColumnWidth
       Next
         hh = .Range("i:i").ColumnWidth                                 

  End With
    Call open_scale(ss, sumwidth, hh, Worksheets("作業チャート表"))
    carray = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbGreen)         

    idx = 5                                                             
    rw = 7                                                                    Do Until idx > row1                                                
       If sht.Cells(idx, 9).Value <> "" And sht.Cells(idx, 11).Value <> "" And sht.Cells(idx, 13).Value <> "" Then  '必須項目のチェック
          If dic.exists(Trim(sht.Cells(idx, 9).Value)) Then
             mkrw = dic(Trim(sht.Cells(idx, 9).Value))

  Else
    mkrw = rw
   rw = rw + 4                                                                  
             dic.Add Trim(sht.Cells(idx, 9).Value), mkrw

       End If
        Worksheets("作業チャート表").Cells(mkrw, 5).Value = sht.Cells(idx, 9).Value     

    If sht.Cells(idx, 15).Value = "増員" Then mkrw = mkrw
    If sht.Cells(idx, 15).Value = "増員" Then carray = Array(vbCyan) '←追加

           If sht.Cells(idx, 6).Value <> "" Then                             
             dstr = sht.Cells(idx, 5).Value & "≫" & sht.Cells(idx, 6).Value & "※" & sht.Cells(idx, 16).Value
              完了予定 = sht.Cells(idx, 13).Value                            

          Else
              dstr = sht.Cells(idx, 5).Value & "≫" & sht.Cells(idx, 6).Value & "**/※" & sht.Cells(idx, 16).Value
             完了予定 = sht.Cells(idx, 13).Value                            

       End If
          Call 作図2(Worksheets("作業チャート表"), mkrw, dstr, _
                  sht.Cells(idx, 11).Value, _
                                 完了予定, _
                  sht.Cells(idx, 11).Value, _
                  sht.Cells(idx, 13).Value, _
                  hh, carray((dic(Trim(sht.Cells(idx, 9).Value)) - 4) / 2 Mod 5))

       End If

       idx = idx + 1                                                       

    Loop
  Set dic = Nothing
 End Sub

  Sub 作図2(ByVal シート As Worksheet, ByVal 作成行 As Long, ByVal 表示文字列 As String _
                             , ByVal 到着時刻 As Date _
                             , ByVal 出発時刻 As Date _
                             , ByVal 作業開始時刻 As Date _
                             , ByVal 作業終了時刻 As Date _
                             , ByVal hh As Single _
                             , Optional ByVal Reccolor As Long = vbRed)

    Dim st As Single
    Dim wk As Double
    Dim shp As Shape
    wk = (出発時刻 - 到着時刻) / TimeSerial(0, 10, 0)
    st = (到着時刻 - TimeSerial(6, 0, 0)) / TimeSerial(0, 10, 0) * hh           
    Set shp = mk_shape(シート.Rows(作成行), st, wk * hh,msoShapeRoundedRectangle, シート)

    With shp
       .TextFrame.Characters.Text = 表示文字列
       .TextFrame.Characters.Font.Color = vbBlack                              
       .TextFrame.Characters.Font.Size = 36                                    
       .TextFrame.HorizontalAlignment = xlHAlignLeft                            
       .TextFrame.VerticalAlignment = xlVAlignTop                             

       .Fill.ForeColor.RGB = Reccolor         
       .Fill.Transparency=0.6                                                       
       .Line.Weight=4                                                              

   End With
 End Sub

行いたい事は、「進捗管理のidx 15に増員の文字がある場合は、色をvbCyanにする」です。

上記のコードを実行すると下記の所が黄色くなってしまいます。
Call 作図2(Worksheets("作業チャート表"), mkrw, dstr, _

                  sht.Cells(idx, 11).Value, _
                                 完了予定, _
                  sht.Cells(idx, 11).Value, _
                  sht.Cells(idx, 13).Value, _
                  hh, carray((dic(Trim(sht.Cells(idx, 9).Value)) - 4) / 2 Mod 5))

 使う色が5色から6色になったからですか?とすれば、どのようなこうどを?
どうかご教授下さい。よろしくお願いします。

< 使用 Excel:Excel2010、使用 OS:Windows8 >


こんにちは

carray = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbGreen)
carray = Array(vbCyan) '←追加
carray((dic(Trim(sht.Cells(idx, 9).Value)) - 4) / 2 Mod 5))

追加した部分だけ見てもコードを理解してない事が分かります。

(ウッシ) 2015/10/22(木) 16:32


ウッシさま

ご教示有難うございます。
申し訳ありません。コードの理解ができておらず。

追加は、

 >carray = Array(vbCyan)の部分だけでしょうか?

すみません。「インデックスが有効範囲にありません」となります。

(yuri) 2015/10/22(木) 19:01


現在の使用色、5色を2色に変更したく、お力をお貸し下さい。

変更箇所は、通常は青色で If sht.Cells(idx, 15).Value = "増員" Then mkrw = mkrw
の場合は赤色で表示させたく思います。

  carray = Array(vbRed)をどこに入れても、青または赤の一色になってしまいます。

又、carray((dic(Trim(sht.Cells(idx, 9).Value)) - 4) / 2 Mod 5)) の部分も
少し変更して試しましたがダメでした。

ご教授を、お願いします。

(yuri) 2015/11/03(火) 00:36


 コードとしては、簡単とは言えないものですが、やはり丹念に1行1行、その意味や機能を
 確かめて吸収する努力をしましょうね。せっかくの機会なんですから。
 動いたからいいということではもったいないですね。

 たとえば、今、躓いている Array。ネット検索やヘルプで、調べてましたか?

 Array は、Variant型変数を1次元配列にして、そこに指定の文字列を格納します。
 1次元配列というのは列車をイメージしてください。先頭が0号車、2番目が1号車、3番目が2号車・・・
 先頭が0号車というところに、ちょっと気を付ける必要がありますが、いずれにしても列車です。

 carray = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbGreen) 

 これは carray号を0号車〜4号車までの5両編成の列車に仕立て上げ、各車両に vbRedさん、vbBlueさん、・・・一人ずつ乗車させています。

 3番目の車両(2号車)に乗っている人は、carry(2) として、参照可能です。この 2 のところは、数値を算出する計算式でも構いません。

 この5両編成の列車を6両編成にして、乗客を一人追加したい場合は

 carray = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbGreen, vbCyan) といったコードでしょうし

 2両編成にしたいということなら

 carray = Array(vbRed, vbBlue) といったコードでしょうね。もっとも2両編成ならArrayをつかわずとも、条件判定で vbRed ないしは vbBlue を
 セットしてやるという手もありますが。

 いずれにしても、carray = Array(vbCyan) は、carray号を、1両のみの電車にしてしまうということなんです。

 で、次に、インデックスエラーですが、たとえば carray号が 6両編成なら 車両参照は carray(0)〜carray(5) までですね。
 carray(7) なんて指定をしたらエラーになります。

 ましてや、carray = Array(vbRed) なんてコードを実行したとしたら1両編成ですから carray(0) しか使えません。
 0 以外何をしていしてもインデックスエラーです。

(β) 2015/11/03(火) 06:46


βさま

ご教授有難うございます。

分かり易く説明して頂いたの参考に、
再度、ネットでArrayやcarrayを調べてみました。

もし2色配列でしたら、
carray = Array(vbBlue, vbRed)

 hh, carray((dic(Trim(sht.Cells(idx, 9).Value)) - 6) / 4 Mod 2))
としたら、規則正しく青、赤の繰り返しで表示されます。

これを基に、1色にしたら、
carray = Array(vbBlue)

 hh, carray((dic(Trim(sht.Cells(idx, 9).Value)) - 1) / 1 Mod 1))で全て青になりました。
この部分は規則正しく全て青でよいのですが、

これに、もう一つ配列を追加させる方法が分かりません。
If sht.Cells(idx, 15).Value = "増員" Then mkrw = mkrw + 2
ここの部分で、"増員"とある場合は、2行下に作図されますが、この色を赤で表示させたいのですが
方法が分かりません。

ネットで調べるとCarray::Appenというのが、配列に別の配列を追加する、とありましたが
どう使うのか、が良くわかりません。

すみません。ご教授願います。

(yuri) 2015/11/03(火) 18:18


 まず、取り組んでおられる具体的な案件に関しては、コードを(最初のトピから継続して)読んではおりませんし
 対象としているシートの要件も把握していませんので、具体的なコード変更のお手伝いは(今の段階では)できません。
 ここは、ichinoseさんのお目に留まりアドバイスをいただければいいですね。

 おそらく・・・ですが、今回の課題は配列の要素を増やすとか減らすといったものではなく

 If なんとか Then
    vbCyanを採用
 Else
    今までの配列からの取り出しロジックを用いる
 ENd If

 こんなことだと思ったりしています。

 次に Append::hoge ですが、これは VBA では使えないのでは?
 MSDNの中を見ても C++ の説明ですので。

 VBA で配列の要素数を変更(追加、ないしは圧縮)する場合、一般には Redim Preserve を使います。
 使っている1次元配列でいいますと

 carray = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbGreen)

 こうして出来上がっている配列に6番目の要素を加えたいなら

 Redim Preserve carray(LBound(carray) To UBound(carray)+1)
 carray(UBound(carray)) = vbCyan

 こうすることで6番目 carray(5) ができあがり、そこに vbCyan という値が収められます。
 ただし、コメントしましたように、今回の課題は、こういったものではないと思います。

 ついでに、2者択一で、交互に値を採用する場合、配列を使わずとも、以下のような制御もできます。
 vbRed と vbBlue を交互に採用しています。

 Sub Test()
    Dim flg As Boolean
    Dim i As Long

    For i = 1 To 5
        flg = Not flg
        If flg Then
            MsgBox vbRed
        Else
            MsgBox vbBlue
        End If
    Next

 End Sub

(β) 2015/11/03(火) 19:24


 carray((dic(Trim(sht.Cells(idx, 9).Value)) - 4) / 2 Mod 5))

 ↑ ここで作図2というプロシジャーに付ける引数の一つですが、これは作図色を指す引数です。

 では、何でこのような式になったのでしょうか?

 根本から考えることです。作図行が 7行目から始まっているのに 又 4行おきに作図することに
 仕様を変更しているのに この式に変化がないことから、変更を忘れているか?
 そもそもわかっていないか どちらかですよね!!

 本来は、多少の変化なら この式を変更しなくてもよいコードにすべきだったんですが、
 これ敢えてしませんでした。私の2年前のトラップです。

 これが分かれば、今回の変更自体は、意外と簡単なんです。

 行に関係なく 作図色は 一緒(例えば 青) ある列のセルに "増員"とあれば 色を赤に代える

 これだけですからね!!

 良く考えることです。

(ichinose) 2015/11/05(木) 06:51


(βさま)

返事が遅くなり、申し訳ありまん。
早期、ご教授有難うございました。

(ichinoseさま)

有難うございます。
度重なる仕様変更で、すみません。
もう一度、良く考えてみます。

(yuri) 2015/11/05(木) 17:12



ichinose様

お世話になっています。
また、数々のご教授、有難うございます。
ここ最近、別の仕事が忙しく、今になってしまいました。

ichinoseさんのおっしゃる通り、過去を振り返り、読み直してみました。

 >carray((dic(Trim(sht.Cells(idx, 9).Value)) - 4) / 2 Mod 5))
 ここの部分については、

 6色なら、-7)/4 Mod6)) 2色は、-7)/4 Mod2)) 1色は、-7) Mod1))
にすると規則性のある色がでました。

今後は、基本は青一色で”増員"とあれば赤にするといった感じになります。

あとは、”増員”とあれば、赤を代入する方法です。よろしくご教授をお願いします。

また、少し変更箇所がございまして、現在は

 > row1 = .Cells(.Rows.Count, "i").End(xlUp).Row                        
   ここの作業責任者名を調べて、

 >  Worksheets("作業チャート表").Cells(mkrw, 5).Value = sht.Cells(idx, 9).Value     
   ここに、進捗管理表の責任者名が上から順に作業チャート表に入力されますが、

これを変更して、

 > row1 = .Cells(.Rows.Count, "i").End(xlUp).Row      
   ここの名前は作業ブループの番号を入力に変更

 > Worksheets("作業チャート表").Cells(mkrw, 5).Value = sht.Cells(idx,9).Value  
  ここに入る番号は、上から勤務始まりが早いグループから番号が入るよにしたいので、
 上から1、2、3、4、5、6、7、となるように変更したいのです。

進捗管理に入る番号は、上から1〜の番号ではありません。
だだ、この作業を、どこのグループに実施してもらうか番号で割り振っているだけです。

合わせて、変更、ご教授をお願いいたします。
(yuri) 2015/11/11(水) 23:51


 >今後は、基本は青一色で”増員"とあれば赤にするといった感じになります。 

 >carray = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbGreen)
 carrayというVariant型の変数を配列にしたのは、作図する行が変わるたびに 赤、青、・・・緑 赤・・
 と作図色を変えるためですよね!!

 では、今度の使用は、通常青一色なのです。

 >Sub 作図2(ByVal シート As Worksheet, ByVal 作成行 As Long, ByVal 表示文字列 As String _
 >                            , ByVal 到着時刻 As Date _
 >                            , ByVal 出発時刻 As Date _
 >                            , ByVal 作業開始時刻 As Date _
 >                            , ByVal 作業終了時刻 As Date _
 >                            , ByVal hh As Single _
 >                            , Optional ByVal Reccolor As Long = vbRed) 

 これが作図2のパラメータです。作図色は、ReccolorというLong型のデータです。

 つまり、色を数字で表しているのです。

 >Call 作図2(Worksheets("作業チャート表"), mkrw, dstr, _
                  sht.Cells(idx, 11).Value, _
                                 完了予定, _
                  sht.Cells(idx, 11).Value, _
                  sht.Cells(idx, 13).Value, _
                  hh, carray((dic(Trim(sht.Cells(idx, 9).Value)) - 4) / 2 Mod 5))

 Call 作図2(Worksheets("作業チャート表"), mkrw, dstr, _
                  sht.Cells(idx, 11).Value, _
                                 完了予定, _
                  sht.Cells(idx, 11).Value, _
                  sht.Cells(idx, 13).Value, _
                  hh, vbBlue)

 青だけで作図するなら、これで良いのです。

 が、条件によって、赤にするのですから、定数ではなく、変数で色を渡すことにします。
 (vbBlueは、文字に見えますが、16711680という青を表す数字です。)

 dim cdata as long '作図色を表す変数

 '↑carrayではなく、作図色変数は、cdataに変えます

 cdata= vbBlue

 If sht.Cells(idx, 15).Value = "増員" Then cdata =vbRed

 ・
 ・

 これである列に「増員」とあれば 作図色は赤になります。

 これで考えてください。

 変更点の方は、具体例を出して、投稿してください

(ichinose) 2015/11/12(木) 23:26



ichinose様

ご教授有難うございます。
早速、上記のように変更してみましたが、
全てが青のままで、条件で赤にはなりません。

(yuri) 2015/11/13(金) 08:58



仕様変更について

下記が現在のコードです。

Sub 新ガントチャート()

  Const ss = 9
    Dim hh As Single                                    
    Dim idx As Long                                     
    Dim rw As Long                                      
    Dim row1 As Long
    Dim mkrw As Long
    Dim col As Long
    Dim cdata as Long                               
    Dim sumwidth As Single
    Dim sht As Worksheet
    Dim dstr As String
    Dim 完了予定 As Date
    Dim dic As Object
    Set dic = CreateObject("scripting.dictionary")
    Set sht = Worksheets("進捗管理")

 With sht
       row1 = .Cells(.Rows.Count, "i").End(xlUp).Row                    

  End With
    With Worksheets("作業チャート表")
       On Error Resume Next
         .DrawingObjects.Delete
         .Columns("a:a").ClearContents
         .Range("F7").Value = "1"

      On Error GoTo 0                                                  
         .Columns("a").ColumnWidth = 16                                  
         .Columns("b").ColumnWidth = 14                                
         .Columns("c:h").ColumnWidth = 8                               
         .Columns("i:dr").ColumnWidth = 8                          

      For idx = 1 To ss - 1
          sumwidth = sumwidth + .Columns(idx).ColumnWidth
       Next
         hh = .Range("i:i").ColumnWidth                                 

   End With
    Call open_scale(ss, sumwidth, hh, Worksheets("作業チャート表"))

    cdata = vbBlue

   idx = 5                                                             
    rw = 7                                                                  
  Do Until idx > row1
       If sht.Cells(idx, 9).Value <> "" And sht.Cells(idx, 11).Value <> "" And sht.Cells(idx, 13).Value <> "" Then
          If dic.exists(Trim(sht.Cells(idx, 9).Value)) Then
             mkrw = dic(Trim(sht.Cells(idx, 9).Value))
  Else
    mkrw = rw
   rw = rw + 4                                                                  
             dic.Add Trim(sht.Cells(idx, 9).Value), mkrw

    End If
        Worksheets("作業チャート表").Cells(mkrw, 5).Value = sht.Cells(idx, 9).Value     

    If sht.Cells(idx, 15).Value = "増員" Then cdata = vbRed

     If sht.Cells(idx, 6).Value <> "" Then                             
             dstr = sht.Cells(idx, 5).Value & "≫" & sht.Cells(idx, 6).Value & "※" & sht.Cells(idx, 16).Value
              完了予定 = sht.Cells(idx, 13).Value                            

            Else
              dstr = sht.Cells(idx, 5).Value & "≫" & sht.Cells(idx, 6).Value & "**/※" & sht.Cells(idx, 16).Value
             完了予定 = sht.Cells(idx, 13).Value                            

       End If
          Call 作図2(Worksheets("作業チャート表"), mkrw, dstr, _
                  sht.Cells(idx, 11).Value, _
                                 完了予定, _
                  sht.Cells(idx, 11).Value, _
                  sht.Cells(idx, 13).Value, _
                  hh, vbBlue)

       End If
    idx = idx + 1                                                       
   Loop
  Set dic = Nothing
 End Sub

Sub 作図2(ByVal シート As Worksheet, ByVal 作成行 As Long, ByVal 表示文字列 As String _

                             , ByVal 到着時刻 As Date _
                             , ByVal 出発時刻 As Date _
                             , ByVal 作業開始時刻 As Date _
                             , ByVal 作業終了時刻 As Date _
                             , ByVal hh As Single _
                             , Optional ByVal Reccolor As Long = vbRed)

    Dim st As Single
    Dim wk As Double
    Dim shp As Shape
    wk = (出発時刻 - 到着時刻) / TimeSerial(0, 10, 0)
    st = (到着時刻 - TimeSerial(6, 0, 0)) / TimeSerial(0, 10, 0) * hh           
    Set shp = mk_shape(シート.Rows(作成行), st, wk * hh,msoShapeRoundedRectangle, シート)

     With shp
       .TextFrame.Characters.Text = 表示文字列
       .TextFrame.Characters.Font.Color = vbBlack                              
       .TextFrame.Characters.Font.Size = 36                                    
       .TextFrame.HorizontalAlignment = xlHAlignLeft                            
       .TextFrame.VerticalAlignment = xlVAlignTop                             
       .Fill.ForeColor.RGB = Reccolor         
       .Fill.Transparency=0.1                                                       
       .Line.Weight=2                                                              

   End With
 End Sub

と上記のよになっておりまして進捗管理の[i]列に責任者名を入力し、その結果を作業チャート表の5列目7行から4行飛ばしで、その責任者名が順に入るような仕様になっています。

変更したい所は、進捗管理の[i]列に番号をランダムに入力し、その結果を作業チャート表の5列目7行から4行飛ばしで番号の小さい順に、つまり1,2,3,4・・・50と順番通りに表示させたいのです。

どうか、ご教授をお願い致します。

(yuri) 2015/11/13(金) 13:00


 >変更したい所
 それは まだまだですね!!
 というより、もっともっとプログラミングの基本からやられたほうが良いです。

 >cdata= vbBlue
 >If sht.Cells(idx, 15).Value = "増員" Then cdata =vbRed
 ↑は、対のコードです。片方は。ループ(Do Until 〜 Loop)外、片方はループの中というような使い方ではありません。よく考えてください。処理手順を考えれば、こんなコードにはなりません。

 cdataという変数には、作図する色の情報が入っているのですよね!!

 では、作図はどこですするのか? cdataという変数に色情報を入れただけでは、その色で作図はしてくれません。

 作図をするところにその色情報を送らなくては、どの色で作図するのかわかりませんよ!!!

 良く考えてください。

 
(ichinose) 2015/11/14(土) 00:56



ichinoseさま

有難うございます。

 >cdata= vbBlue
  を作図する所に、送りました。

Do Until idx > row1

       If sht.Cells(idx, 9).Value <> "" And sht.Cells(idx, 11).Value <> "" And sht.Cells(idx, 13).Value <> "" Then
          If dic.exists(Trim(sht.Cells(idx, 9).Value)) Then
             mkrw = dic(Trim(sht.Cells(idx, 9).Value))
  Else
    mkrw = rw
   rw = rw + 4                                                                  
             dic.Add Trim(sht.Cells(idx, 9).Value), mkrw

    End If

        Worksheets("作業チャート表").Cells(mkrw, 5).Value = sht.Cells(idx, 9).Value     

  cdata = Blue

    If sht.Cells(idx, 15).Value = "増員" Then cdata = vbRed

  If sht.Cells(idx, 6).Value <> "" Then                             
             dstr = sht.Cells(idx, 5).Value & "≫" & sht.Cells(idx, 6).Value & "※" & sht.Cells(idx, 16).Value
              完了予定 = sht.Cells(idx, 13).Value                            

           Else
              dstr = sht.Cells(idx, 5).Value & "≫" & sht.Cells(idx, 6).Value & "**/※" & sht.Cells(idx, 16).Value
             完了予定 = sht.Cells(idx, 13).Value                            

        End If
          Call 作図2(Worksheets("作業チャート表"), mkrw, dstr, _
                  sht.Cells(idx, 11).Value, _
                                 完了予定, _
                  sht.Cells(idx, 11).Value, _
                  sht.Cells(idx, 13).Value, _
                  hh, cdata)

このよに、変更したら、ちゃんと色がでました。

(yuri) 2015/11/14(土) 07:12


 >このよに、変更したら、ちゃんと色がでました。
 ここまでは、2年前までのコードを理解されていれば、もともとのコードより、簡単なはずなんです。

 図形を作成する箇所は難しいだろうなあ と思いましたし、過去にガントチャート作成プログラムを作ったことがあったのでそれのテストも兼ねて提示しましたが、そこから先は、yuriさんが作成するのですよ。
 私は、2年前もそうでしたが、そのまま動くようなコードを提示するつもりはありません。

 で、質問の続きですが・・・。

 >変更したい所は、進捗管理の[i]列に番号をランダムに入力し、その結果を作業チャート表の5列目7行から4行飛ばしで番号の小さい順に、つまり1,2,3,4・・・50と順番通りに表示させたいのです。 

 私は、

 >変更点の方は、具体例を出して、投稿してください

 と申し上げました。
 入力データや出力データが変わるという事は、大きな仕様変更の可能性があります。

 具体例をだして 既述するべきです。現に前投稿ではそうされていますよね!!

 VBAでやりたいことをわかりやすさを心がけて記述する、 これがプログラムの仕様書を記述する勉強です。

 今回でしたら、
 今までの 入力データ例とそれに対する作図(図形の作成位置の概略)の説明

 新仕様での入力データ例、それに対する作図(図形の作成位置の概略)の説明

 これらの例を引用して、入力データと 作図順序の関係を明確にすることです。

(ichinose) 2015/11/14(土) 21:44



ichinose様

大変失礼いたしました。
改めて記述します。

現在の仕様

 (データ入力表)進捗表

         E          F          I                K                M
     車両名  出発便名  責任者名  作業スタート時間  作業完了時間 

 5      1号車    111         田中      06:30            07:30
 6      2号車    222         山田            07:00            08:00
 7      3号車    333         佐藤      09:45            10:30
 8      4号車    333         田中      09:45            10:30
 9
 10
 ・
 ・ 
 と150行あります。
 このデータを基に作業チャート表に作図していますが図の中は「1号車/111」と車両名と便名が入ります。

 (作業チャート表)

          E           I〜
       責任者名   06時から24時までのチャート表

 7      田中
 11      山田
 15      佐藤

 と責任者名は入力データ表の名前を上から順に入力され、同じ名前がある場合は、同じ行に作図さてれいます。(名前はE7から4行飛ばしで)

 これからの新仕様を説明します。

 (データ入力表)進捗表

         E          F          I                K                M
     車両名  出発便名  責任者   作業スタート時間  作業完了時間 

 5      1号車    111         2      06:30            07:30
 6      2号車    222         5            07:00            08:00
 7      3号車    333         1      09:45            10:30
 8      4号車    444         3      08:45            09:30
 9      5号車    555         7      09:45            10:30
 9      6号車    666         2      09:45            10:30
10
 ・
とI列の作業責任者名を番号入力に変更します。この番号はランダムです。

このデータを基に作業チャートの表示は、何番の番号は何号車を実施するのかをチャートに作図します。

 (作業チャート表)

           E           I〜DR列
       責任者番号   06時から24時までのチャート表

 7         1      3号車/333   を7行目に作図

 11        2      1号車/111  6号車/666    を11行目に作図

 15        3      4号車/444     を15行目に作図

 19        4      

 23        5      2号車/222     を23行目に作図

 27        6

 31        7            5号車/555     を31行目に作図

 と1〜順番に表示されるようにしたいのです。E列の1からの番号は固定です。(1〜35まで)
 (7行目から4行飛ばしの変更はありません)

 少しわかりにくいかも知れませんが、よろしくお願い致します。
(yuri) 2015/11/14(土) 23:54

 大体理解はしたつもりです。

 進捗表のシートは、実際 どこの列から どこの列までにデータが入っているのですか?

 投稿されている内容からだと E F I K M それぞれの列のデータ例の提示から内容はわかりましたが、
 表自体は E列から どこまでの列までで表になっているのですか?

 例えば 表自体は A列から始まっているいのか? 終わりは 「増員」という文字列のあるなしで色を変える
 ということから、O列は あるのでしょうが、本当は何列まであるのですか?

 この問題、E列の責任者番号で整列させれば 仕様の8割は出来そうです。
 整列させるなら 表全体で整列させた方が 他に変更があった場合にも対応できそうなので
 お聞きしました。

 事前に 進捗表を別シートにコピー(進捗表コピー)、進捗表コピーにて 責任者番号で整列、

 この進捗表コピーのデータを基に作図を行う 

 という手順です。

 進捗表のデータ列の範囲を記述してください。

(ichinose) 2015/11/15(日) 21:21



ichinoseさま

色々と、お世話になっています。進捗表ですが下記のようになっています。

   A     B      C          D       E        G           F  H      I          K            M   

4 番号 場所 到着便名 到着時間 車両名 出発便名  作業内容 責任者  作業開始時間 完了時間
 

   O      P

 増員  特記事項

と表はAからP列まであります。 150行まで

よろしくお願い致します。 
(YURI) 2015/11/15(日) 21:53


 Option Explicit
 Sub 新ガントチャート()
    Const ss = 9
    Dim hh As Single
    Dim idx As Long
    Dim rw As Long
    Dim row1 As Long
    Dim mkrw As Long
    Dim col As Long
    Dim cdata As Long
    Dim sumwidth As Single
    Dim sht As Worksheet
    Dim sht2 As Worksheet
    Dim dstr As String
    Dim 完了予定 As Date
    Dim dic As Object
    Set dic = CreateObject("scripting.dictionary")
    Set sht2 = Worksheets("作業チャート表")
    Set sht = Worksheets("進捗管理")
    Set sht = copy_進捗管理(sht, row1) '
    With sht2
       On Error Resume Next
       .DrawingObjects.Delete
       .Columns("a:a").ClearContents
       .Range("F7").Value = "1"
       On Error GoTo 0
       .Columns("a").ColumnWidth = 16
       .Columns("b").ColumnWidth = 14
       .Columns("c:dr").ColumnWidth = 8
       For idx = 1 To ss - 1
          sumwidth = sumwidth + .Columns(idx).ColumnWidth
       Next
       hh = .Range("i:i").ColumnWidth
    End With
    Call open_scale(ss, sumwidth, hh, sht2)
    idx = 5
    rw = 7
    Do Until idx > row1
       If sht.Cells(idx, 9).Value <> "" And sht.Cells(idx, 11).Value <> "" And sht.Cells(idx, 13).Value <> "" Then  '必須項目のチェック
          If dic.exists(Trim(sht.Cells(idx, 9).Value)) Then
             mkrw = dic(Trim(sht.Cells(idx, 9).Value))
          Else
             mkrw = rw
             rw = rw + 4
             dic.Add Trim(sht.Cells(idx, 9).Value), mkrw
          End If
          sht2.Cells(mkrw, 5).Value = sht.Cells(idx, 9).Value
          If sht.Cells(idx, 6).Value <> "" Then
             dstr = sht.Cells(idx, 5).Value & "≫" & sht.Cells(idx, 6).Value & "※" & sht.Cells(idx, 16).Value
              完了予定 = sht.Cells(idx, 13).Value
          Else
              dstr = sht.Cells(idx, 5).Value & "≫" & sht.Cells(idx, 6).Value & "**/※" & sht.Cells(idx, 16).Value
             完了予定 = sht.Cells(idx, 13).Value
          End If
          If sht.Cells(idx, 15).Value = "増員" Then cdata = vbRed Else cdata = vbBlue

          Call 作図2(sht2, mkrw, dstr, _
                  sht.Cells(idx, 11).Value, _
                                 完了予定, _
                  sht.Cells(idx, 11).Value, _
                  sht.Cells(idx, 13).Value, _
                  hh, cdata)
       End If
       idx = idx + 1
    Loop
    Set dic = Nothing
    sht.Parent.Close False
    Set sht = Nothing
    Set sht2 = Nothing
 End Sub
 Function copy_進捗管理(ByVal sht As Worksheet, lastrw As Long) As Worksheet
    sht.Copy
    Set copy_進捗管理 = ActiveWorkbook.ActiveSheet
    With copy_進捗管理
       lastrw = .Cells(.Rows.Count, "i").End(xlUp).Row
       .Sort.SortFields.Clear
       .Sort.SortFields.Add Key:=Range("I5:I" & lastrw) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
       With .Sort
         .SetRange Range("A4:P" & lastrw)
         .Header = xlYes
         .MatchCase = False
         .Orientation = xlTopToBottom
         .SortMethod = xlPinYin
         .Apply
       End With
    End With
 End Function

 これで試してください、責任者番号順に作図されるはずです・・・。

 さて、ここからです。yuriさんの仕様とは違います。ここから修正してください。
 どこが違うか 調べてください

 尚、今まで提示した ガントチャート作成モジュールや 作図2というプロシジャーは、当然必要ですよ!!

(ichinose) 2015/11/16(月) 06:14



ichinoseさま

度重なる変更の対応、本当に有難うございました。
早速、確認しました。

思った通りになりました。

一点確認させて下さい。
作図される縦の位置ですが、3行目以降から、少しずつずれて表示されます。
当初より、縦のセル幅を、かなり広くとっているからでしょうか?
修正方法を、ご教授ねがいますか?
よろしくお願いいたします。
(yuri) 2015/11/16(月) 09:50


 >思った通りになりました。 
 先に提示された結果とは 違うと思いますけどねえ

 >当初より、縦のセル幅を、かなり広くとっているからでしょうか?
 いつ、セル幅を広く取ったのですか?
 広くした時から ずれているのですか?
 それとも 今回提示したコードからですか?

 こうなると、作業チャート表というシートのレイアウトも共通のレイアウトを使用しなければ
 ならないかもしれません。

 ずれて表示をもう少し詳しく記述出来れば お願いします。

(ichinose) 2015/11/16(月) 21:16



ichinoseさま

縦のセル幅をかなり広くしたのは、4日位前で
広くしてから、少しは、ずれていましたが、再度マクロ実行
したら、修正されていました。

今回は、その修正も、効かなくなっていました。
セル内には収まっていますが、上から
4番目の図から、下方に少しずつ ずれています。

一番下の図は、下の線から図が半分位、出ています。

(yuri) 2015/11/16(月) 21:56


 >縦のセル幅をかなり広くした
 私も行のセル幅を極端に200ポイントぐらいにして試しましたが、
 問題が再現できません。

 この手の問題は、やはり、お互い同じものをみて動作させないと原因に到達できないかもしれません。

 今、時間がとれないのでちょっと待ってください。同期のとれるデータやレイアウトを使い、検証することを
 考えます。

(ichinose) 2015/11/18(水) 06:57



ichinoseさま

色々とお世話になっております。

図が少しはみ出すと、言っても、作図を4行毎に作って
いるので、一つのグループで、一つは図の行と、その他三つの行も
別のオートシェイプで使っています。

今回のズレは、その4行の中には、納まっているので、大きな問題は
ございません。

こちらの、縦幅ですが、一つのグループで、

 60 = 今回ずれる図  (以前は40で最近60に変更)
 1 =  セルを塗りつぶしている部分
 20 = 別のオートシェイプ
 20 = 別のオートシェイプ   となっています。

  お忙しいとこ、本当にすみません。
(yuri) 2015/11/18(水) 11:13


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.