[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『7曜日カレンダーで工程管理』（マクロ初心者）
下記の様なSheet1からSheet2へ時間単位のガントチャートみたいな3時間を1セルで見える感じのイメージで
品名、開始時刻、終了時刻の表示も希望します。
週をまたがない場合は両矢印で週をまたぐ場合は片矢印としたいです。
皆様のお知恵をお借りしたいと思います。
宜しくお願いします。
Sheet1
A B C 品名 開始日時 終了日時 サンマ 2019/11/3 1:30 2019/11/5 3:00
タイ 2019/11/8 3:00 2019/11/10 21:00
カツオ 2019/11/14 21:00 2019/11/18 5:30
Sheet2
______A___ B____C____D____E____F____G____ 1 <2019>年 <11>月 2 日 月 火 水 木 金 土 3 1 2 4 5 3 4 5 6 7 8 9 6 ←――――→ ←―― 7 10 11 12 13 14 15 16 8 ――→ ←―――― 9 17 18 19 20 21 22 23 10 ――――→ 11 24 25 26 27 28 29 30 12
＜ 使用 Excel：Excel2013、使用 OS：Windows8 ＞
ちょっと書いてみました。。。 試作品です。。。
↓このコードでカレンダーのレイアウトを作ってから、、
Option Explicit
Private Sub SoulMan()
Rem 結合状態を処理
Range("A1:H1").Merge
Range("I1:P1").Merge
Range("A2:H2").Merge
Range("I2:P2").Merge
Range("Q2:X2").Merge
Range("Y2:AF2").Merge
Range("AG2:AN2").Merge
Range("AO2:AV2").Merge
Range("AW2:BD2").Merge
Range("A3:H3").Merge
Range("I3:P3").Merge
Range("Q3:X3").Merge
Range("Y3:AF3").Merge
Range("AG3:AN3").Merge
Range("AO3:AV3").Merge
Range("AW3:BD3").Merge
Range("A5:H5").Merge
Range("I5:P5").Merge
Range("Q5:X5").Merge
Range("Y5:AF5").Merge
Range("AG5:AN5").Merge
Range("AO5:AV5").Merge
Range("AW5:BD5").Merge
Range("A7:H7").Merge
Range("I7:P7").Merge
Range("Q7:X7").Merge
Range("Y7:AF7").Merge
Range("AG7:AN7").Merge
Range("AO7:AV7").Merge
Range("AW7:BD7").Merge
Range("A9:H9").Merge
Range("I9:P9").Merge
Range("Q9:X9").Merge
Range("Y9:AF9").Merge
Range("AG9:AN9").Merge
Range("AO9:AV9").Merge
Range("AW9:BD9").Merge
Range("A11:H11").Merge
Range("I11:P11").Merge
Range("Q11:X11").Merge
Range("Y11:AF11").Merge
Range("AG11:AN11").Merge
Range("AO11:AV11").Merge
Range("AW11:BD11").Merge
Rem 数式セル以外をまとめて処理
Range("A1").Value = 2019
Range("I1").Value = 12
Range("A2").Value = "日"
Range("I2").Value = "月"
Range("Q2").Value = "火"
Range("Y2").Value = "水"
Range("AG2").Value = "木"
Range("AO2").Value = "金"
Range("AW2").Value = "土"
Rem 数式セルをまとめて処理
Range("A3").FormulaR1C1Local = "=IF(WEEKDAY(DATE(R1C1,R1C9,1))=1,DATE(R1C1,R1C9,1),"""")"
Range("I3").FormulaR1C1Local = "=IF(RC[-8]<>"""",RC[-8]+1,IF(WEEKDAY(DATE(R1C1,R1C9,1))=2,DATE(R1C1,R1C9,1),""""))"
Range("Q3").FormulaR1C1Local = "=IF(RC[-8]<>"""",RC[-8]+1,IF(WEEKDAY(DATE(R1C1,R1C9,1))=3,DATE(R1C1,R1C9,1),""""))"
Range("Y3").FormulaR1C1Local = "=IF(RC[-8]<>"""",RC[-8]+1,IF(WEEKDAY(DATE(R1C1,R1C9,1))=4,DATE(R1C1,R1C9,1),""""))"
Range("AG3").FormulaR1C1Local = "=IF(RC[-8]<>"""",RC[-8]+1,IF(WEEKDAY(DATE(R1C1,R1C9,1))=5,DATE(R1C1,R1C9,1),""""))"
Range("AO3").FormulaR1C1Local = "=IF(RC[-8]<>"""",RC[-8]+1,IF(WEEKDAY(DATE(R1C1,R1C9,1))=6,DATE(R1C1,R1C9,1),""""))"
Range("AW3").FormulaR1C1Local = "=IF(RC[-8]<>"""",RC[-8]+1,IF(WEEKDAY(DATE(R1C1,R1C9,1))=7,DATE(R1C1,R1C9,1),""""))"
Range("A5,A7,A9,A11").FormulaR1C1Local = "=R[-2]C[48]+1"
Range("I5,Q5,Y5,AG5,AO5,AW5,I7,Q7").FormulaR1C1Local = "=RC[-8]+1"
Range("Y7,AG7,AO7,AW7,I9,Q9,Y9,AG9").FormulaR1C1Local = "=RC[-8]+1"
Range("AO9,AW9,I11,Q11,Y11,AG11,AO11,AW11").FormulaR1C1Local = "=RC[-8]+1"
Rem 標準外書式セルをまとめて処理
Range("A3:BD3,A5:BD5,A7:BD7,A9:BD9,A11:BD11").NumberFormatLocal = "d"
Range("BI3").NumberFormatLocal = "yyyy/m/d h:mm;@"
Rem 塗りつぶしセルをまとめて処理
Rem 列幅をまとめて処理
Range("A1:BD11").ColumnWidth = 0.54
Range("BE1:BH11").ColumnWidth = 8.38
Range("BI1:BI11").ColumnWidth = 15.5
Rem 行高さをまとめて処理
Range("A1:BI11").RowHeight = 13.5
MsgBox "お題の作成が完了しました。"
End Sub
↓このコードを走らせてみて下さい。。。
取り敢えず、、Sheet1の B2 と C2 しか見てません。。。＿|￣|○
あとは、、応用してください。。。
もう寝ます
おやみなさい。。zzzzzzzzzzzzzzzzzzzzzz
Option Explicit
Sub てすと()
Dim v As Variant
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim 品名 As String
Dim 開始 As String
Dim 終了 As String
Dim i As Long
Set Sh1 = Sheets("Sheet1")
Set Sh2 = Sheets("Sheet2")
v = Sh1.Range("A1").CurrentRegion.Resize(, 3).Value
Sh2.DrawingObjects.Delete
For i = 1 To UBound(v, 1)
If (IsDate(v(i, 2))) * (IsDate(v(i, 3))) Then
品名 = v(i, 1)
開始 = Format(v(i, 2), "H:mm")
終了 = Format(v(i, 3), "H:mm")
ガンチャート v(i, 2), v(i, 3), Sh1, Sh2, 品名, 開始, 終了
End If
Next
MsgBox "処理が完了しました。。。"
End Sub
Sub ガンチャート(ByVal MyDateA As Date, _
ByVal MyDateB As Date, _
ByVal Sh1 As Worksheet, _
ByVal Sh2 As Worksheet, _
ByVal 品名 As String, _
ByVal 開始 As String, _
ByVal 終了 As String)
Dim x As Variant
Dim MyS As Single
Dim MyDate As Date
Dim Sr As Range
Dim Er As Range
Dim SEr As Range
Dim ESr As Range
Dim STr As Range
Dim ETr As Range
Dim 高さ As Single
Dim 色 As Long
Dim i As Long
Static k As Long
k = k + 1
If k Mod 4 = 0 Then k = 1
MyDate = Format(MyDateA, "yyyy/mm/dd")
For i = 3 To 12 Step 2
x = Application.Match(CLng(MyDate), Sh2.Range("A" & i).Resize(, 56), 0)
If Not IsError(x) Then
MyS = Int((TimeValue(MyDateA) * 24) / 3)
Set Sr = Sh2.Range("A" & i + 1).Item(1, x).Offset(, MyS)
Set SEr = Sh2.Range("BE" & i + 1)
Set STr = Sh2.Range("A" & i + 3)
Exit For
End If
Next
MyDate = Format(MyDateB, "yyyy/mm/dd")
For i = 3 To 12 Step 2
x = Application.Match(CLng(MyDate), Sh2.Range("A" & i).Resize(, 56), 0)
If Not IsError(x) Then
MyS = Int((TimeValue(MyDateB) * 24) / 3)
Set Er = Sh2.Range("A" & i + 1).Item(1, x).Offset(, MyS)
Set ESr = Sh2.Range("A" & i + 1)
Set ETr = Sh2.Range("BE" & i - 1)
Exit For
End If
Next
If (Not Sr Is Nothing) * (Not Er Is Nothing) Then
Select Case k
Case 1
色 = vbRed
高さ = (Sr.Height / k)
Case 2
色 = vbBlack
高さ = (Sr.Height / k)
Case 3
色 = vbYellow
高さ = 0
End Select
If Sr.Row = Er.Row Then
With Sh2.Shapes.AddLine(Sr.Left, Sr.Top + 高さ, Er.Left, Er.Top + 高さ).Line
.ForeColor.RGB = 色
.Weight = 1.5
.EndArrowheadStyle = msoArrowheadTriangle
.BeginArrowheadStyle = msoArrowheadTriangle
End With
With Sh2.Shapes.AddTextbox(msoTextOrientationHorizontal, Sr.Left, Sr.Top + 高さ - 10, Er.Left, Er.Top + 高さ)
.Line.Visible = False
.Fill.Visible = False
With .TextFrame
.AutoSize = True
.Characters.Text = 品名 & " " & 開始
.Characters.Font.Size = 6
End With
End With
With Sh2.Shapes.AddTextbox(msoTextOrientationHorizontal, Er.Left - 10, Er.Top + 高さ - 10, Er.Left, Er.Top + 高さ)
.Line.Visible = False
.Fill.Visible = False
With .TextFrame
.AutoSize = True
.Characters.Text = 品名 & " " & 終了
.Characters.Font.Size = 6
End With
End With
Else
If Er.Row - Sr.Row = 4 Then
With Sh2.Shapes.AddLine(STr.Left, STr.Top + 高さ, ETr.Left, ETr.Top + 高さ).Line
.ForeColor.RGB = 色
.Weight = 1.5
End With
With Sh2.Shapes.AddLine(Sr.Left, Sr.Top + 高さ, SEr.Left, SEr.Top + 高さ).Line
.ForeColor.RGB = 色
.Weight = 1.5
.BeginArrowheadStyle = msoArrowheadTriangle
End With
With Sh2.Shapes.AddLine(ESr.Left, ESr.Top + 高さ, Er.Left, Er.Top + 高さ).Line
.ForeColor.RGB = 色
.Weight = 1.5
.EndArrowheadStyle = msoArrowheadTriangle
End With
With Sh2.Shapes.AddTextbox(msoTextOrientationHorizontal, Sr.Left, Sr.Top + 高さ - 10, Er.Left, Er.Top + 高さ)
.Line.Visible = False
.Fill.Visible = False
With .TextFrame
.AutoSize = True
.Characters.Text = 品名 & " " & 開始
.Characters.Font.Size = 6
End With
End With
With Sh2.Shapes.AddTextbox(msoTextOrientationHorizontal, Er.Left - 10, Er.Top + 高さ - 10, Er.Left, Er.Top + 高さ)
.Line.Visible = False
.Fill.Visible = False
With .TextFrame
.AutoSize = True
.Characters.Text = 品名 & " " & 終了
.Characters.Font.Size = 6
End With
End With
Else
With Sh2.Shapes.AddLine(Sr.Left, Sr.Top + 高さ, SEr.Left, SEr.Top + 高さ).Line
.ForeColor.RGB = 色
.Weight = 1.5
.BeginArrowheadStyle = msoArrowheadTriangle
End With
With Sh2.Shapes.AddLine(ESr.Left, ESr.Top + 高さ, Er.Left, Er.Top + 高さ).Line
.ForeColor.RGB = 色
.Weight = 1.5
.EndArrowheadStyle = msoArrowheadTriangle
End With
With Sh2.Shapes.AddTextbox(msoTextOrientationHorizontal, Sr.Left, Sr.Top + 高さ - 10, Er.Left, Er.Top + 高さ)
.Line.Visible = False
.Fill.Visible = False
With .TextFrame
.AutoSize = True
.Characters.Text = 品名 & " " & 開始
.Characters.Font.Size = 6
End With
End With
With Sh2.Shapes.AddTextbox(msoTextOrientationHorizontal, Er.Left - 10, Er.Top + 高さ - 10, Er.Left, Er.Top + 高さ)
.Line.Visible = False
.Fill.Visible = False
With .TextFrame
.AutoSize = True
.Characters.Text = 品名 & " " & 終了
.Characters.Font.Size = 6
End With
End With
End If
End If
Else
MsgBox "日付を検索出来ませんでした。"
End If
End Sub
（SoulMan） 2019/11/04(月) 02:08
おはようございます。
昨夜、寝ながら書いたので今朝ちょっと見直しました。
Sheet1は
__A__________B_______________________C______________
開始 終了 カツオ 2019/12/2 12:00 2019/12/12 10:00 マグロ 2019/12/14 13:00 2019/12/18 14:00 イカ 2019/12/21 12:00 2019/12/28 15:00
みたいにしてます。
でも、書いた本人が言うのもなんですけど、、、これ、、何かの練習台にはいいでしょうけど、、 実務には耐えないと思いますよ(^^;
一応、、ループ処理も追加しておきました。
ご健闘をお祈り致します。
では、、では、、また、、、 （SoulMan） 2019/11/04(月) 08:36
2）品名を日付に対応する空欄に記入して行けばいいように思いますが、
図形で線を引かないとだめですか？
（まっつわん） 2019/11/04(月) 09:39
重なりも三つまでなら(^^;
こりゃぁ、、大変だよ(笑)
頑張ってくださいね(^^; （SoulMan） 2019/11/04(月) 10:44
高さ、、、と言えば、、色・・・ですよねぇ(^^;
わかってますよ。。。では、、では、、、 （SoulMan） 2019/11/04(月) 11:23
こんにちは ＾＾ カレンダー作ってしまったのですね。。。トレビア〜ン Soulmanさんが最初にご提示の分、月だけ、11、に 変えるとそのまま矢印図形が表示されましたですよ。（＾◇＾）ｖ なにか、大作になりそぉですね。勉強出来そうで。 楽しみです。マクロ初心者さん、お邪魔しました すみません。 （隠居じーさん） 2019/11/04(月) 12:19
おはようございます😃 いつもありがとうございます これも思わず 書いちゃった パターンです 暇つぶしです(^^;; 線を描くところの高さをもっとも広げて 区分けしてもいいかもしれませんね 私は、もうやりませんけどね(笑) 今日もよろしくお願いします😊 （SoulMan） 2019/11/04(月) 12:28
Soulman さんへ こちらこそ宜しくお願い致します。m(__)m でわでわ (#^ ^#) （隠居じーさん） 2019/11/04(月) 13:13
思っていた通りの矢印図形が表示されました。
ありがとうございました。
品名、開始時刻、終了時刻の表示は無理でしょうか？
宜しくお願いします。
（マクロ初心者） 2019/11/04(月) 20:17
1）期間が重なることはありません。
2) 出来れば図形で線を引きたいですが・・・
宜しくお願いします。
（マクロ初心者） 2019/11/04(月) 20:20
こんばんは！
もう呑んじゃったからね。。酔拳・・・です。(^^;
師匠が呑めばのむほどに・・・あっ、、あれは、、チェーンか？？？
わちきの師匠は、、Lee・・・Don't Think Bee Feel！！！！ もう。。考える力も残ってませんけど。。＿|￣|○
すみません。。冗談は、、これくらいにして、、コードの中の -10 というのは調整ですから、、適当に調整してみて下さい。
だんだん、、難しくなってきましたね(^^;
でも、明日から仕事なんで、、ほとんどみれませんから、、お許しをm(__)m
まぁ、、わからいことがあればどなたかが教えてくださりますから、、、大丈夫ですけどね。。。
頑張ってくださいね。。。では、、では、、 （SoulMan） 2019/11/04(月) 22:58
コードの中の -10 というのは調整なんですね・・・
明日職場で調整してみますね。楽しみです。現状のセルに合わせてみて不明な点等
また質問すると思います。ありがとうございました。
（マクロ初心者） 2019/11/05(火) 00:07
こんばんは品名、時刻の表示位置を調整して思っていた通りの事が出来ました。ありがとうございました。
後出しで申し訳ございませんが引取り項目を追加出来ればと思います。
__A__________B_______________________C____________________D____________
開始 終了 引取り カツオ 2019/12/2 12:00 2019/12/12 10:00 2019/12/13 13:00 マグロ 2019/12/14 13:00 2019/12/18 14:00 2019/12/20 15:00 イカ 2019/12/21 12:00 2019/12/28 15:00 2019/12/29 10:00
結果図
______A___ B____C____D____E____F____G____ 1 <2019>年 <11>月 2 日 月 火 水 木 金 土 3 1 2 4 5 3 4 5 6 7 8 9 6 ←――――→ ←―― 7 10 11 12 13 14 15 16 8 ――→ ‐‐‐→ 引取り ←― 9 17 18 19 20 21 22 23 10 ――――→ 11 24 25 26 27 28 29 30 12
上記の様に‐‐‐→ （点線矢印）で引取りと表示出来たら最高です。
それから項目を今後増えても対応出来る様に何処を変更又は追加したかいいのか
教えていただきたい。お仕事のお忙しいところ恐れ入りますが宜しくお願いします。
（マクロ初心者） 2019/11/05(火) 21:14
こんばんは！
ちょっと検証不足気味ですけど、、どうかなぁ？？？
無茶苦茶見通しが悪くなっちゃいましたね(^^;
本当はサブルーチンを使って整理すればいいんでしょうけど、、取り敢えず、、動く様にしてみました。。
でも、、後は、、応用してくださいよ。。。わちきももう年なんで無理が効かないのです＿|￣|○(笑)
出来る範囲でね。。。では、、では、、、
Option Explicit
Sub てすと()
Dim v As Variant
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim 品名 As String
Dim 開始 As String
Dim 終了 As String
Dim 引取 As String
Dim i As Long
Set Sh1 = Sheets("Sheet1")
Set Sh2 = Sheets("Sheet2")
v = Sh1.Range("A1").CurrentRegion.Resize(, 4).Value
Sh2.DrawingObjects.Delete
For i = 1 To UBound(v, 1)
If (IsDate(v(i, 2))) * (IsDate(v(i, 3))) * (IsDate(v(i, 4))) Then
品名 = v(i, 1)
開始 = Format(v(i, 2), "h:mm")
終了 = Format(v(i, 3), "h:mm")
引取 = Format(v(i, 4), "h:mm")
ガンチャート v(i, 2), v(i, 3), v(i, 4), Sh1, Sh2, 品名, 開始, 終了, 引取
End If
Next
Set Sh1 = Nothing
Set Sh2 = Nothing
Erase v
MsgBox "処理が完了しました。。。"
End Sub
Private Sub ガンチャート( _
ByVal MyDateA As Date, _
ByVal MyDateB As Date, _
ByVal MyDateC As Date, _
ByVal Sh1 As Worksheet, _
ByVal Sh2 As Worksheet, _
ByVal 品名 As String, _
ByVal 開始 As String, _
ByVal 終了 As String, _
ByVal 引取 As String)
Dim x As Variant
Dim MyS As Single
Dim MyDate As Date
Dim Sr As Range
Dim Er As Range
Dim SEr As Range
Dim ESr As Range
Dim STr As Range
Dim ETr As Range
Dim Hr As Range
Dim HSr As Range
Dim HEr As Range
Dim HTSr As Range
Dim HTEr As Range
Dim HETr As Range
Dim 高さ As Single
Dim 色 As Long
Dim i As Long
Static k As Long
k = k + 1
If k Mod 4 = 0 Then k = 1
MyDate = Format(MyDateA, "yyyy/mm/dd")
For i = 3 To 12 Step 2
x = Application.Match(CLng(MyDate), Sh2.Range("A" & i).Resize(, 56), 0)
If Not IsError(x) Then
MyS = Int((TimeValue(MyDateA) * 24) / 3)
Set Sr = Sh2.Range("A" & i + 1).Item(1, x).Offset(, MyS)
Set SEr = Sh2.Range("BE" & i + 1)
Set STr = Sh2.Range("A" & i + 3)
Exit For
End If
Next
MyDate = Format(MyDateB, "yyyy/mm/dd")
For i = 3 To 12 Step 2
x = Application.Match(CLng(MyDate), Sh2.Range("A" & i).Resize(, 56), 0)
If Not IsError(x) Then
MyS = Int((TimeValue(MyDateB) * 24) / 3)
Set Er = Sh2.Range("A" & i + 1).Item(1, x).Offset(, MyS + 1)
Set ESr = Sh2.Range("A" & i + 1)
Set ETr = Sh2.Range("BE" & i - 1)
Set HETr = Sh2.Range("BE" & i + 1)
Exit For
End If
Next
MyDate = Format(MyDateC, "yyyy/mm/dd")
For i = 3 To 12 Step 2
x = Application.Match(CLng(MyDate), Sh2.Range("A" & i).Resize(, 56), 0)
If Not IsError(x) Then
MyS = Int((TimeValue(MyDateC) * 24) / 3)
Set Hr = Sh2.Range("A" & i + 1).Item(1, x).Offset(, MyS + 1)
Set HSr = Sh2.Range("A" & i + 1)
Set HEr = Sh2.Range("BE" & i + 1)
Set HTSr = Sh2.Range("A" & i - 1)
Set HTEr = Sh2.Range("BE" & i - 1)
Exit For
End If
Next
If (Not Sr Is Nothing) * (Not Er Is Nothing) * (Not Hr Is Nothing) Then
Select Case k
Case Is = 1
色 = vbRed
高さ = (Sr.Height / k)
Case Is = 2
色 = vbBlack
高さ = (Sr.Height / k)
Case Is = 3
色 = vbYellow
高さ = 0
End Select
Select Case Sr.Row - Er.Row
Case Is = 0
実線始点終点 Sr.Left, Sr.Top + 高さ, Er.Left, Er.Top + 高さ, Sh2, 色
ラベル Sr.Left, Sr.Top + 高さ - 10, Er.Left, Er.Top + 高さ, Sh2, 品名, 開始
ラベル Er.Left - 10, Er.Top + 高さ - 10, Er.Left, Er.Top + 高さ, Sh2, 品名, 終了
Case Is = -2
実線始点 Sr.Left, Sr.Top + 高さ, SEr.Left, SEr.Top + 高さ, Sh2, 色
実線終点 ESr.Left, ESr.Top + 高さ, Er.Left, Er.Top + 高さ, Sh2, 色
ラベル Sr.Left, Sr.Top + 高さ - 10, Er.Left, Er.Top + 高さ, Sh2, 品名, 開始
ラベル Er.Left - 10, Er.Top + 高さ - 10, Er.Left, Er.Top + 高さ, Sh2, 品名, 終了
Case Is = -4
実線始点 Sr.Left, Sr.Top + 高さ, SEr.Left, SEr.Top + 高さ, Sh2, 色
実線中間 STr.Left, STr.Top + 高さ, ETr.Left, ETr.Top + 高さ, Sh2, 色
実線終点 ESr.Left, ESr.Top + 高さ, Er.Left, Er.Top + 高さ, Sh2, 色
ラベル Sr.Left, Sr.Top + 高さ - 10, Er.Left, Er.Top + 高さ, Sh2, 品名, 開始
ラベル Er.Left - 10, Er.Top + 高さ - 10, Er.Left, Er.Top + 高さ, Sh2, 品名, 終了
End Select
Select Case Er.Row - Hr.Row
Case Is = 0
点線終点 Er.Left, Er.Top + 高さ, Hr.Left, Hr.Top + 高さ, Sh2, 色
ラベル Hr.Left - 10, Hr.Top + 高さ - 10, Hr.Left, Hr.Top + 高さ, Sh2, 品名, 引取
Case Is = -2
点線始点 Er.Left, Er.Top + 高さ, HTEr.Left, HTEr.Top + 高さ, Sh2, 色
点線終点 HSr.Left, HSr.Top + 高さ, Hr.Left, Hr.Top + 高さ, Sh2, 色
ラベル Hr.Left - 10, Hr.Top + 高さ - 10, Hr.Left, Hr.Top + 高さ, Sh2, 品名, 引取
Case Is = -4
点線始点 Er.Left, Er.Top + 高さ, HETr.Left, HETr.Top + 高さ, Sh2, 色
点線中間 HTSr.Left, HTSr.Top + 高さ, HTEr.Left, HTEr.Top + 高さ, Sh2, 色
点線終点 HSr.Left, HSr.Top + 高さ, Hr.Left, Hr.Top + 高さ, Sh2, 色
ラベル Hr.Left - 10, Hr.Top + 高さ - 10, Hr.Left, Hr.Top + 高さ, Sh2, 品名, 引取
End Select
Else
MsgBox "日付を検索出来ませんでした。"
End If
Set Sr = Nothing
Set Er = Nothing
Set SEr = Nothing
Set ESr = Nothing
Set STr = Nothing
Set ETr = Nothing
Set Hr = Nothing
Set HSr = Nothing
Set HEr = Nothing
Set HTSr = Nothing
Set HTEr = Nothing
Set HETr = Nothing
End Sub
Private Sub 実線始点終点(ByVal Bx As Single, ByVal By As Single, ByVal Ex As Single, ByVal Ey As Single, ByVal ws As Worksheet, ByVal 色 As Long)
With ws.Shapes.AddLine(Bx, By, Ex, Ey).Line
.ForeColor.RGB = 色
.Weight = 1.5
.BeginArrowheadStyle = msoArrowheadTriangle
.EndArrowheadStyle = msoArrowheadTriangle
End With
End Sub
Private Sub 実線中間(ByVal Bx As Single, ByVal By As Single, ByVal Ex As Single, ByVal Ey As Single, ByVal ws As Worksheet, ByVal 色 As Long)
With ws.Shapes.AddLine(Bx, By, Ex, Ey).Line
.ForeColor.RGB = 色
.Weight = 1.5
End With
End Sub
Private Sub 実線始点(ByVal Bx As Single, ByVal By As Single, ByVal Ex As Single, ByVal Ey As Single, ByVal ws As Worksheet, ByVal 色 As Long)
With ws.Shapes.AddLine(Bx, By, Ex, Ey).Line
.ForeColor.RGB = 色
.Weight = 1.5
.BeginArrowheadStyle = msoArrowheadTriangle
End With
End Sub
Private Sub 実線終点(ByVal Bx As Single, ByVal By As Single, ByVal Ex As Single, ByVal Ey As Single, ByVal ws As Worksheet, ByVal 色 As Long)
With ws.Shapes.AddLine(Bx, By, Ex, Ey).Line
.ForeColor.RGB = 色
.Weight = 1.5
.EndArrowheadStyle = msoArrowheadTriangle
End With
End Sub
Private Sub 点線始点(ByVal Bx As Single, ByVal By As Single, ByVal Ex As Single, ByVal Ey As Single, ByVal ws As Worksheet, ByVal 色 As Long)
With ws.Shapes.AddLine(Bx, By, Ex, Ey).Line
.ForeColor.RGB = 色
.Weight = 1.5
.DashStyle = msoLineSysDot
End With
End Sub
Private Sub 点線中間(ByVal Bx As Single, ByVal By As Single, ByVal Ex As Single, ByVal Ey As Single, ByVal ws As Worksheet, ByVal 色 As Long)
With ws.Shapes.AddLine(Bx, By, Ex, Ey).Line
.ForeColor.RGB = 色
.Weight = 1.5
.DashStyle = msoLineSysDot
End With
End Sub
Private Sub 点線終点(ByVal Bx As Single, ByVal By As Single, ByVal Ex As Single, ByVal Ey As Single, ByVal ws As Worksheet, ByVal 色 As Long)
With ws.Shapes.AddLine(Bx, By, Ex, Ey).Line
.ForeColor.RGB = 色
.Weight = 1.5
.DashStyle = msoLineSysDot
.EndArrowheadStyle = msoArrowheadTriangle
End With
End Sub
Private Sub ラベル(ByVal Bx As Single, ByVal By As Single, ByVal Ex As Single, ByVal Ey As Single, ByVal ws As Worksheet, ByVal 品名 As String, ByVal ラベル As String)
With ws.Shapes.AddTextbox(msoTextOrientationHorizontal, Bx, By, Ex, Ey)
.Line.Visible = False
.Fill.Visible = False
With .TextFrame
.AutoSize = True
.Characters.Text = 品名 & " " & ラベル
.Characters.Font.Size = 6
End With
End With
End Sub
（SoulMan） 2019/11/05(火) 23:51
おはようございます。
朝はめっきり寒くなりましたね。ぶるぶる
今朝、動かしてみたらこちらでは動きましたが、、ちょっと気になるところを 修正してみましたので試してみて下さい。
まぁ、昼間はどうせみれませんから、、今晩、帰ってからまた見てみます。
では、、では、、 （SoulMan） 2019/11/06(水) 05:49
おはようございます ＾＾ 修正前(多分)の分でも正常に作動していましたですよ。こちらでも ＾＾ｖ さむいっすね (#^^#)。。。ぶるぶる！ぶる （＾◇＾） あの〜。。。たぶんですが かれんだ〜 が 11月度で、処理情報は １２月 になっていません でしょうか。 m(_ _)m （隠居じーさん） 2019/11/06(水) 06:34
おはようございます☀ いつもありがとうございます😊 （SoulMan） 2019/11/06(水) 08:48
（マクロ初心者） 2019/11/06(水) 12:48
内容が気になったので、SoulManさんのを参考に勉強させていただきました。
ありがとうございます。
ちなみに最新版の方で動作しましたよ。
（マルフク） 2019/11/06(水) 14:49
こんばんは！ 今日は少し早く帰って来ました。もう呑んじゃってますけど、、(^^;
で、トピ主さんが出来ない理由を考えていたんですけど、、
多分、、トピ主さんは、、
>上記の様に‐‐‐→ （点線矢印）で引取りと表示出来たら最高です。
なので、、
2019/12/13 引取り
なんて入力してませんか？
そうすると、、↓ここではじかれてSheet2には何も表示されません。
If (IsDate(v(i, 2))) * (IsDate(v(i, 3))) * (IsDate(v(i, 4))) Then
でも、、でも、、ですよ
これは、、私の推測なのですが、こういった掲示板で見ず知らずの人が接する中で、、何人かの人が「出来る」と言ってる中で
かたくなに、、2019/12/13 引取り と入力するかなぁ？？？とは考えました。。。
一回でも、、2019/12/13 13:00 と入力すれば、、表示されるわけで、、、
もちろん追加のコードを書いている時にチラッとは見ました。 でも、そうしなかったのは、自分でもよく分かりませんが、、トピ主さんの本気度をみたかったのかぁ？とは思います。(自分でもよくわかりません。m(__)m）
で、なにが言いたいかというと、、追加の質問はいいんですよ。別に、、私もコードを書きたくて書いてるわけですから。。 私は、自分のスキルアップの為に書いているわけで、トピ主さんの為とか、ご指導しようとかは、、微塵も思っていなくて、、、
上手くいえませんが、、、そうすると、、質問の内容が変わってくると思うんですよね？
例えば、、2019/12/13 13:00 と入力すると、、13:00 と表示されますが、、
2019/12/13 引取り と入力すると、、表示されません。。とかね。。
これ、凄く大事で、、コードを書く人というのは、コードを書きながら色んなことを考える様になります。
ああなって、、こうなって、、こうなると、、まずいな。。とかね。。
なので、、最初から、、後は、、応用してください。。となるのです。
で、答えから言いますと、、今のコードのままでは、、引取り とは表示されません。
でも、、
ラベル Hr.Left - 10, Hr.Top + 高さ - 10, Hr.Left, Hr.Top + 高さ, Sh2, 品名, 引取
Private Sub ラベル(ByVal Bx As Single, ByVal By As Single, ByVal Ex As Single, ByVal Ey As Single, ByVal ws As Worksheet, ByVal 品名 As String, ByVal ラベル As String)
ラベルに渡している引数を変数の 引取 から "引取り" にすれば、、表示されると思います。。多分、、
その前に、、開始 終了 引取 を全て日付にする必要がありますけどね。。。
まぁ、、私の一方的な推測で書いてますから、、間違ってましたら、、本当にごめんなさい。。ですけどね。。
だいぶん、、酔ってるわ＿|￣|○
あっ、、サブルーチンでコードを整理してみました。。。(それを先に言わんかえ、、おっさん！！！ はい！すみません。m(__)m） （SoulMan） 2019/11/06(水) 19:51
こんばんは、開始 終了 引取を日付形式にしたらサブルーチンコード前でも動作しました。
表示形式が時刻となっておりました。
またお仕事を早く切り上げて頂いて申し訳ございません。最高のコードを作って貰って
思っていた通りの動作するので感動的です。
マクロの参考書を見ても記載していないと思います。すっごく嬉しいです。
ありがとうございました。エクセル学校の回答者の皆さんは神の領域を超える人ばかりです。
ネットで調べても参考書を見ても載って無い事を一瞬で解決へと導いてくれます。
これからも不明な点を聞きながら自分のスキルを上げていきたいです。
ありがとうございました。
（マクロ初心者） 2019/11/06(水) 21:06
こんばんは先日はありがとうございました。 また教えていただきたい事があり投稿しました。別の使い方をしたいので 品名、開始日、終了日と時刻を入れずに日付と品名を表示したいです。 お仕事のお忙しいところ恐れ入りますが宜しくお願いします。
__A__________B________________C_________
品名 開始日 終了日 カツオ 2019/12/3 2019/12/5 マグロ 2019/12/8 2019/12/11 イカ 2019/12/21 2019/12/21
結果図
______A___ B____C____D____E____F____G____ 1 <2019>年 <12>月 2 日 月 火 水 木 金 土 3 1 2 4 5 3 4 5 6 7 8 9 6 ←カツオ――→ ←マグロ 7 10 11 12 13 14 15 16 8 ―――→ 9 17 18 19 20 21 22 23 10 ←イカ――――→ 11 24 25 26 27 28 29 30 12
（マクロ初心者） 2019/11/18(月) 21:49
こんばんは！
編集するのは難しい？ですかぁ？？？(^^;
削って動く様にしただけですよ
後は、応用してくださいね(^^;
では、、では、、
Option Explicit
Sub てすと()
Dim v As Variant
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim 品名 As String
Dim 開始 As String
Dim 終了 As String
Dim 引取 As String
Dim i As Long
Set Sh1 = Sheets("Sheet1")
Set Sh2 = Sheets("Sheet2")
v = Sh1.Range("A1").CurrentRegion.Resize(, 3).Value
Sh2.DrawingObjects.Delete
For i = 1 To UBound(v, 1)
If (IsDate(v(i, 2))) * (IsDate(v(i, 3))) Then
品名 = v(i, 1)
ガンチャート v(i, 2), v(i, 3), Sh1, Sh2, 品名
End If
Next
Set Sh1 = Nothing
Set Sh2 = Nothing
Erase v
MsgBox "処理が完了しました。。。"
End Sub
Private Sub ガンチャート( _
ByVal MyDateA As Date, _
ByVal MyDateB As Date, _
ByVal Sh1 As Worksheet, _
ByVal Sh2 As Worksheet, _
ByVal 品名 As String)
Dim x As Variant
Dim MyS As Single
Dim MyDate As Date
Dim Sr As Range
Dim Er As Range
Dim SEr As Range
Dim ESr As Range
Dim STr As Range
Dim ETr As Range
Dim Hr As Range
Dim HSr As Range
Dim HEr As Range
Dim HTSr As Range
Dim HTEr As Range
Dim HETr As Range
Dim 高さ As Single
Dim 色 As Long
Dim i As Long
Static k As Long
k = k + 1
If k Mod 4 = 0 Then k = 1
MyDate = Format(MyDateA, "yyyy/mm/dd")
For i = 3 To 12 Step 2
x = Application.Match(CLng(MyDate), Sh2.Range("A" & i).Resize(, 7), 0)
If Not IsError(x) Then
MyS = Int((TimeValue(MyDateA) * 24) / 3)
Set Sr = Sh2.Range("A" & i + 1).Item(1, x).Offset(, MyS)
Set SEr = Sh2.Range("H" & i + 1)
Set STr = Sh2.Range("A" & i + 3)
Exit For
End If
Next
MyDate = Format(MyDateB, "yyyy/mm/dd")
For i = 3 To 12 Step 2
x = Application.Match(CLng(MyDate), Sh2.Range("A" & i).Resize(, 7), 0)
If Not IsError(x) Then
MyS = Int((TimeValue(MyDateB) * 24) / 3)
Set Er = Sh2.Range("A" & i + 1).Item(1, x).Offset(, MyS + 1)
Set ESr = Sh2.Range("A" & i + 1)
Set ETr = Sh2.Range("H" & i - 1)
Set HETr = Sh2.Range("H" & i + 1)
Exit For
End If
Next
If (Not Sr Is Nothing) * (Not Er Is Nothing) Then
Select Case k
Case Is = 1
色 = vbRed
高さ = (Sr.Height / k)
Case Is = 2
色 = vbBlack
高さ = (Sr.Height / k)
Case Is = 3
色 = vbYellow
高さ = 0
End Select
Select Case Sr.Row - Er.Row
Case Is = 0
実線始点終点 Sr.Left, Sr.Top + 高さ, Er.Left, Er.Top + 高さ, Sh2, 色
ラベル Sr.Left, Sr.Top + 高さ - 10, Er.Left, Er.Top + 高さ, Sh2, 品名
ラベル Er.Left - 10, Er.Top + 高さ - 10, Er.Left, Er.Top + 高さ, Sh2, 品名
Case Is = -2
実線始点 Sr.Left, Sr.Top + 高さ, SEr.Left, SEr.Top + 高さ, Sh2, 色
実線終点 ESr.Left, ESr.Top + 高さ, Er.Left, Er.Top + 高さ, Sh2, 色
ラベル Sr.Left, Sr.Top + 高さ - 10, Er.Left, Er.Top + 高さ, Sh2, 品名
ラベル Er.Left - 10, Er.Top + 高さ - 10, Er.Left, Er.Top + 高さ, Sh2, 品名
Case Is = -4
実線始点 Sr.Left, Sr.Top + 高さ, SEr.Left, SEr.Top + 高さ, Sh2, 色
実線中間 STr.Left, STr.Top + 高さ, ETr.Left, ETr.Top + 高さ, Sh2, 色
実線終点 ESr.Left, ESr.Top + 高さ, Er.Left, Er.Top + 高さ, Sh2, 色
ラベル Sr.Left, Sr.Top + 高さ - 10, Er.Left, Er.Top + 高さ, Sh2, 品名
ラベル Er.Left - 10, Er.Top + 高さ - 10, Er.Left, Er.Top + 高さ, Sh2, 品名
End Select
Else
MsgBox "日付を検索出来ませんでした。"
End If
Set Sr = Nothing
Set Er = Nothing
Set SEr = Nothing
Set ESr = Nothing
Set STr = Nothing
Set ETr = Nothing
Set Hr = Nothing
Set HSr = Nothing
Set HEr = Nothing
Set HTSr = Nothing
Set HTEr = Nothing
Set HETr = Nothing
End Sub
Private Sub 実線始点終点(ByVal Bx As Single, ByVal By As Single, ByVal Ex As Single, ByVal Ey As Single, ByVal ws As Worksheet, ByVal 色 As Long)
With ws.Shapes.AddLine(Bx, By, Ex, Ey).Line
.ForeColor.RGB = 色
.Weight = 1.5
.BeginArrowheadStyle = msoArrowheadTriangle
.EndArrowheadStyle = msoArrowheadTriangle
End With
End Sub
Private Sub 実線中間(ByVal Bx As Single, ByVal By As Single, ByVal Ex As Single, ByVal Ey As Single, ByVal ws As Worksheet, ByVal 色 As Long)
With ws.Shapes.AddLine(Bx, By, Ex, Ey).Line
.ForeColor.RGB = 色
.Weight = 1.5
End With
End Sub
Private Sub 実線始点(ByVal Bx As Single, ByVal By As Single, ByVal Ex As Single, ByVal Ey As Single, ByVal ws As Worksheet, ByVal 色 As Long)
With ws.Shapes.AddLine(Bx, By, Ex, Ey).Line
.ForeColor.RGB = 色
.Weight = 1.5
.BeginArrowheadStyle = msoArrowheadTriangle
End With
End Sub
Private Sub 実線終点(ByVal Bx As Single, ByVal By As Single, ByVal Ex As Single, ByVal Ey As Single, ByVal ws As Worksheet, ByVal 色 As Long)
With ws.Shapes.AddLine(Bx, By, Ex, Ey).Line
.ForeColor.RGB = 色
.Weight = 1.5
.EndArrowheadStyle = msoArrowheadTriangle
End With
End Sub
Private Sub 点線始点(ByVal Bx As Single, ByVal By As Single, ByVal Ex As Single, ByVal Ey As Single, ByVal ws As Worksheet, ByVal 色 As Long)
With ws.Shapes.AddLine(Bx, By, Ex, Ey).Line
.ForeColor.RGB = 色
.Weight = 1.5
.DashStyle = msoLineSysDot
End With
End Sub
Private Sub 点線中間(ByVal Bx As Single, ByVal By As Single, ByVal Ex As Single, ByVal Ey As Single, ByVal ws As Worksheet, ByVal 色 As Long)
With ws.Shapes.AddLine(Bx, By, Ex, Ey).Line
.ForeColor.RGB = 色
.Weight = 1.5
.DashStyle = msoLineSysDot
End With
End Sub
Private Sub 点線終点(ByVal Bx As Single, ByVal By As Single, ByVal Ex As Single, ByVal Ey As Single, ByVal ws As Worksheet, ByVal 色 As Long)
With ws.Shapes.AddLine(Bx, By, Ex, Ey).Line
.ForeColor.RGB = 色
.Weight = 1.5
.DashStyle = msoLineSysDot
.EndArrowheadStyle = msoArrowheadTriangle
End With
End Sub
Private Sub ラベル(ByVal Bx As Single, ByVal By As Single, ByVal Ex As Single, ByVal Ey As Single, ByVal ws As Worksheet, ByVal 品名 As String)
With ws.Shapes.AddTextbox(msoTextOrientationHorizontal, Bx, By, Ex, Ey)
.Line.Visible = False
.Fill.Visible = False
With .TextFrame
.AutoSize = True
.Characters.Text = 品名
.Characters.Font.Size = 6
End With
End With
End Sub
（SoulMan） 2019/11/18(月) 22:53
ありがとうございました。ですが・・・終了日が一日ずれます。
（マクロ初心者） 2019/11/19(火) 00:32
こんばんは！
すみませんね。遅くなってしましました。m(__)m
>終了日が一日ずれます。
これですけど、、確かに(^^;
でも、、でも、、ですよぉ、、、そんな入り方をすると話がややこしくなります。
このコードを書いたときにどう考えていたかは不明ですけど、、
一日を3時間で割ったので細かいところまで見ていなかたんでしょうね(^^; でも、、みるべきですよね。すみません。
で、解決策ですけど、、セルには高さ と 幅 がありますけど、、Left しか見てませんから、日にちはづれていないわけです。
Sr とか Er は Start と End の略だと思います。 セルには一日の幅あるのですね。なので、終了にあたるポイントは無条件で一つ右のセルへShiftすればいいと思います。
具体的に言うと↓ E End の入った変数を +1 すればいいのでは？？
Set Er = Sh2.Range("A" & i + 1).Item(1, x).Offset(, MyS)
↓
Set Er = Sh2.Range("A" & i + 1).Item(1, x).Offset(, MyS + 1)
^^^^^^^^^^
最初のコードも含めて直したつもりですが、、直ってないところもあるかも(^^;
もうね。。根気がないのよ＿|￣|○ でも、、考え方だけは、、あってると思いますので、、
是非是非、、応用してください。
では、、、では、、、または、、ないかもね(^^; （SoulMan） 2019/11/19(火) 20:20
SoulManさん
思っていた通りの事が出来ました。 ありがとうございました。 または、あるかもしれませんが・・・ その時は宜しくお願いします。 （マクロ初心者） 2019/11/19(火) 21:11
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.