Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7 Professional : Excel 2013)
カレンダーにスケジュールと矢印を自動で引く
投稿日時: 18/09/06 13:02:03
投稿者: hahahaaki

https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q14113813044
を参考にカレンダーを横一列のものに変更したものを作成しています。
 
2018
9月
----------------------------
1 |2 |3 |4 |5 |6 |7 |8 |9 |10|...
----------------------------
土|日|月|火|水|木|金|土|日|月|...
----------------------------
  | | | | | | | | | |...
-----------------------------
----------------------------
  | | | | | | | | | |... 6行ほどあり
-----------------------------
2018
10月
----------------------------
1 |2 |3 |4 |5 |6 |7 |8 |9 |10|...
----------------------------
月|火|水|木|金|土|日|月|火|水|...
----------------------------
  | | | | | | | | | |...
-----------------------------
  | | | | | | | | | |... 6行ほどあり
 
この横に、項目と開始、終了日と表示させる行の番号を入力する列があります。
参考にしたものを加工して表示させたいのですが、日付がづれて表示されてしまいます。
どこを修正すれば日付の取得がうまくいくのかわからず投稿しました。
年と月などは関数で取得し表示させています。
 
Sub スケジュール表示()
'****************************************************************
'変数の指定 (integer)整数 (string)文字列 (Variant)データ
'****************************************************************
 Dim r As Long
 Dim date1 As Date
 Dim date2 As Date
 Dim date3 As Date
 Dim rofs As Integer
 Dim rng As Range
 Dim sh As Shape
 Dim c As Double
 Dim cofs As Double
 Dim ws As Worksheet
 
'****************************************************************
'作業シート(予定の文字列の長さ取得用)
'****************************************************************
Set ws = Sheets("作業用シート")
 
'****************************************************************
'図形(Shape)を消す
'****************************************************************
ActiveSheet.DrawingObjects.Delete
 
'****************************************************************
'【】内の文字を消す
'****************************************************************
Range("A:AF").Replace What:="【*】", Replacement:="", LookAt:=xlWhole
 
'****************************************************************
'スケジュール行の初期値
'****************************************************************
r = 7
Do While Range("AH" & r).Value <> ""
date1 = Range("AJ" & r).Value '注目行の開始日
date2 = Range("AK" & r).Value '注目行の終了日
rofs = Range("AL" & r).Value '注目行の行
 
'****************************************************************
'開始日のセルを取得
'****************************************************************
Set rng = findCell(Year(date1), Month(date1), Day(date1), rofs)
 
'****************************************************************
'セルが無ければ終わり(エラー)
'****************************************************************
If rng Is Nothing Then Exit Sub
 
'****************************************************************
'開始日のセルに予定をコピー
'****************************************************************
rng.Value = Range("AH" & r).Value
 
'****************************************************************
'予定の色をコピー
'****************************************************************
rng.Font.ColorIndex = Range("AH" & r).Font.ColorIndex
 
'****************************************************************
'矢印用に色を取得
'****************************************************************
c = Range("AH" & r).Font.Color
 
'****************************************************************
'ここから4行で作業シートのA1を使って予定の文字列の長さを取得
'****************************************************************
'****************************************************************
'作業シートクリア
'****************************************************************
ws.Cells.Delete
 
'****************************************************************
'予定の文字列を作業シートのA1にコピー
'****************************************************************
rng.Copy ws.Range("A1")
 
'****************************************************************
'作業シートのA列の横幅を合わせる
'****************************************************************
ws.Range("A:A").EntireColumn.AutoFit
 
'****************************************************************
'予定文字列の横幅を取得
'****************************************************************
cofs = ws.Range("A:A").Width
 
'****************************************************************
'矢印表示(と言っても面倒なので1日ずつの線を書く)
'****************************************************************Do
'****************************************************************
'開始日のセルを取得
'****************************************************************
Do
Set rng = findCell(Year(date1), Month(date1), Day(date1), rofs)
 
'****************************************************************
'セルが無ければ終わり(エラー)
'****************************************************************
If rng Is Nothing Then Exit Sub
 
'****************************************************************
'対象のセルに横線を引く(ただし予定の文字列分(cofs)を除く)
'****************************************************************
Set sh = ActiveSheet.Shapes.AddLine(rng.Left + cofs, rng.Top + rng.Height / 2, rng.Left + rng.Width, rng.Top + rng.Height / 2)
 
'****************************************************************
'2予定の文字列の長さを0にする(次からセルの横幅いっぱいの線になる)
'****************************************************************
cofs = 0
 
'****************************************************************
'線の色を指定
'****************************************************************
sh.Line.ForeColor.RGB = c
 
'****************************************************************
'もし終了日なら矢印設定
'****************************************************************
If date1 = date2 Then
sh.Line.EndArrowheadStyle = msoArrowheadTriangle
sh.Line.EndArrowheadLength = msoArrowheadLengthMedium
sh.Line.EndArrowheadWidth = msoArrowheadWidthMedium
End If
 
'****************************************************************
'次の日
'****************************************************************
date1 = date1 + 1
 
'****************************************************************
'終了日を超えたら終わり
'****************************************************************
Loop Until date1 > date2
r = r + 1
 Loop
 End Sub
'****************************************************************
'指定年月日行のセルを取得する関数
'y=年,m=月,d=日,rofs=行
'C列で年の下のセルの値がm+"月"の場合、その月のカレンダーの開始点として、日は計算で出す
'****************************************************************
Function findCell(y As Integer, m As Integer, d As Integer, rofs As Integer) As Range
 Dim rng As Range
 Dim adr As String
 Dim ofs As Integer
 Dim r As Long
 Dim c As Integer
'****************************************************************
'B列で年を検索
'****************************************************************
 Set rng = Range("B:B").Find(y)
 
'****************************************************************
'見つかったら
'****************************************************************
If Not rng Is Nothing Then
 
'****************************************************************
'終了検出用に最初に見つけたアドレスを記憶
'****************************************************************
adr = rng.Address
'****************************************************************
'年の下のセルが月+"月"なら対象の年月のカレンダーの最初の位置なので
'****************************************************************
Do
 If rng.Offset(1).Text = m & "月" Then
 
'****************************************************************
'1日の位置を算出
'****************************************************************
ofs = Weekday(DateSerial(y, m, 1), vbMonday) - 1
 
'****************************************************************
'対象年月日+行の行
'****************************************************************
r = ((d + ofs - 1) \ 31) * 4 + 3 + rng.Row
 
'****************************************************************
'対象年月日の列
'****************************************************************
c = ((d + ofs - 1) Mod 32) + 2
  
'****************************************************************
'そのセルを戻り値にセット
'****************************************************************
Set findCell = Cells(r + rofs, c)
 
'****************************************************************
'戻る
'****************************************************************
Exit Function
End If
 
'****************************************************************
'B列で次の年を検索
'****************************************************************
 Set rng = Range("B:B").FindNext(rng)
 
'****************************************************************
'最初のアドレスなら終わり
'****************************************************************
Loop Until rng.Address = adr
End If
 MsgBox Format(DateSerial(y, m, d), "yyyy年m月d日") & "のカレンダーがありません"
Set findCell = Nothing '戻り値はNothing(見つからなかった)
End Function
 

回答
投稿日時: 18/09/06 17:18:46
投稿者: WinArrow
投稿者のウェブサイトに移動

>注目行
というコメントが書いてあるが、どこなのか?よくわかりません。
 
 
インデントをきちんとつけましょう
 
ステップ実行をしてみましょう。
 
ステップ実行をすれば、意図しない「値」がセットされてるところが分かります。
 

投稿日時: 18/09/06 21:44:03
投稿者: hahahaaki

申し訳ありません。
再度試してみます。

回答
投稿日時: 18/09/08 07:17:48
投稿者: simple

こんにちは。
>日付がづれて表示されてしまいます。
既にご指摘を頂いていますが、
入力データの行番号、列番号をしっかりつけて提示してくださいね。
そして、出力もどこにどんなものを、という説明が必要です。
(とりわけデバッグを他人にお願いしていることになっているわけですから、
  最低限必要ではないでしょうか。)
また、「ずれて表示」についても、
想定と現実でどう違うのか説明が欲しいところです。
 
詳細には見ていませんが、
・週毎に一行単位にするのと、
・ひと月で一行にする
というデータフォーマットの違いがありますが、
単に7を31(ないし32)に変更しただけだから、
ということではないですか?
後者は、1日は、必ず1列目(のようです)が、
前者は、曜日の関係でかならずしも1列目と限らない、
それを補正するためのロジックが残っているから、
ということでしょう。
 
出発点に戻って考えれば、
ワークシートのデータの持ち方として、
・データは日付型
・表示だけ日とする(ユーザー定義で d とする)
としておけば、日にちの検索は
Findを使った一行だけでダイレクトに求められるはず
ですね。
 
そうしたアプローチで再考してみてはいかがですか?
 
# それにしても
# '****************************************************************
# を多用しすぎていませんか?
# かえって見にくくないですか。ご自由ではあるんですが。

投稿日時: 18/09/08 20:21:21
投稿者: hahahaaki

ありがとうございます
ヒントをいただいたので、勉強し作成したいと思います
たしかに、と思うところが、かなりあります。
助かりました