エクセルVBAで日付に合わせて図形を動かす際に土日を考慮外にしたい

エクセルVBA初心者です。
今ガントチャートを作っているのですが、添付の図のように青いバーが今日を表す図形で、列１つが週単位になっています。日では無く週単位にしたくてこのようになっています。
ネットで検索しつつ自力で「ブックを開いたら本日の位置にバーが移動する」こと自体は実現できたのですが、列１つを７で割って移動させているので土日も含めた均等な幅でバーが動いていく状態です。
添付の図はD列の真ん中に位置していますが、7/8(水)ではなく7/9(木)にこの位置になります。
これを、土日は金曜の位置で止まっているようにして水曜が列のど真ん中に来る形にしたいと考えています。
6/29からどれくらい日が経っているかのカウント(変数 Count)が 1, 2, 3, 4, 5, 5, 5, 8, 9, 10, 11, 12, 12, 12, 15, 16... と変化していってくれれば実現できると思ってるのですが、どういう風に計算させれば実現できるでしょうか‥。

ちなみに今は下記のような記述になっています。
ご教授いただけますとありがたく思います。m(_ _)m

Private Sub Workbook_Open()
'エクセルと開くと自動で実行する関数

Dim Col As Integer '列番号
Dim StartDay As Long '開始日
Dim ToDay As Long '本日の日付
Dim Count As Long 'タイムバーの移動値
Dim MoveValue As Double '１日の移動量
Dim MovePos As Double 'タイムバーの移動値

'今日の日付を取得
ToDay = CDbl(Date)
'開始日
StartDay = 44011
'経過日数
Count = ToDay - StartDay

'移動値
MoveValue = 93.75 / 7
MovePos = MoveValue * Count

With ActiveSheet.Shapes("タイムバー")
.Top = Cells(4, 3).Top
.Left = Cells(3, 3).Left + MovePos + 6.7
End With '線を移動
End Sub

No.2 ベストアンサー 回答者： めぐみん_ 回答日時： 2020/07/10 12:40

No.1です。

あちらの回答は間違っているようですので無視ってください。
多分週の列がズレそうな予感が・・・

.Left = Cells(3, 3).Left + MovePos - IIf(WorksheetFunction.Weekday(Date, 2) < 6, 0, (WorksheetFunction.Weekday(Date, 2) - 5) * MoveValue) + 6.7

こちらが週の列内での位置決めをされているのでしょう。
なので月～金を超えた日数分
'移動値
MoveValue = 93.75 / 7

の MoveValue （１日の移動量）分を補正してあげれば良いような。。。未検証で申し訳ないですが。

この回答へのお礼

めぐみんさん
いつもお世話になっています！
めぐみんさんの記述を試してみてうまくいかなかったのですが考え方はとても参考になりまして、その後は自力で無事達成することができました（関数をうまく扱えていなくて冗長ですが‥）。
ありがとうございました！

Private Sub Workbook_Open()
'エクセルと開くと自動で実行する関数

　Dim Col As Integer '列番号
　Dim StartDay As Long '開始日
　Dim ToDay As Long '本日の日付
　Dim CountDay As Long '経過日数
　Dim CountWeek As Long '経過した週
　Dim ColWidth As Double '列の幅
　Dim MoveStep As Double '列内での移動ステップ数
　Dim MoveWeek As Double '現在の週までの移動量
　Dim MoveValue As Double '総移動量

　'今日の日付を取得
　ToDay = CDbl(Date)
　'開始日
　StartDay = 44011
　'経過日数
　CountDay = ToDay - StartDay
　'経過した週
　CountWeek = Fix(CountDay / 7)
　'列の幅
　ColWidth = 93.75

　'現在の週の列までの移動量を求める
　MoveWeek = ColWidth * CountWeek

　'列内での移動ステップ数を求める
　MoveStep = CountDay Mod 7
　Select Case MoveStep
　Case Is = 5
　　MoveStep = 4
　Case Is = 6
　　MoveStep = 4
　End Select

　'総移動値を求める
　MoveValue = MoveWeek + ((ColWidth / 5) * MoveStep)

　With ActiveSheet.Shapes("日付バー")
　　.Top = Cells(4, 3).Top
　　.Left = Cells(4, 3).Left + MoveValue + (ColWidth / 10)
　End With '線を移動

End Sub

お礼日時：2020/07/11 16:32

No.6 回答者： tom04 回答日時： 2020/07/11 18:33

No.3・4・5です。

何度もごめんなさい。
使っていないセルにシリアル値を入れ「DATE」の代わりにそのセルを「今日」に見立てて確認してみると
第1週（月またぎ）の場合に不具合がありました。

前回のコードの
ActiveSheet.Shapes.AddShape(msoShapeRectangle, c.Left + (Day(Date) - Day(myStart)) * c.Width / 5, c.Top, _
　　c.Width / 5, r.Top - c.Top + r.Height).Select '//②//

を
ActiveSheet.Shapes.AddShape(msoShapeRectangle, c.Left + (WorksheetFunction.Weekday(Date, 2) - 1) * c.Width / 5, c.Top, _
c.Width / 5, r.Top - c.Top + r.Height).Select

に変更してください。m(_ _)m

この回答へのお礼

tom04さん
わざわざ実際に組んでいただいてすみません‥！
ご提示いただいたコードを試してみたのですが、型が違うとエラーが出てしまいました。。
tom04さんの手元でうまくいかれているということは私の方に問題があると思うのですが、tom04さんのコード内容を読み解けていないため、どこが問題かはわかっておりません。。
実は自力でうまくいきまして、めぐみんさんのNo.2のコメントへのお礼の欄に、うまく動作した内容を記載しております。
ですがtom04さんの「土曜に表示を消す」など「なるほど‥！」と思いました。
今後の参考にさせていただきます‥！ありがとうございます。m(_ _)m

お礼日時：2020/07/11 20:04

No.5 回答者： tom04 回答日時： 2020/07/11 18:19

たびたびごめんなさい。

No.4の

＞No.2です。
は
＞No.3です。
の間違いです。

どうも失礼しました。m(_ _)m

No.4 回答者： tom04 回答日時： 2020/07/11 18:16

No.2です。

どうも失礼しました。
前回のコードはセル幅を7分割していました。
結局、月～金　までの5分割でよいのですね。

ただ、線（オートシェイプ）の幅が広くなってしまいますが、
前回のコードに少し手を加えてみました。

Sub Sample2()
　Dim c As Range, r As Range
　Dim myStart As Date, myEnd As Date
　Dim j As Long
　Dim mySp As Shape

　　With Worksheets("Sheet1") '//←実際のシート名に！★//
　　　.Activate
　　　　For j = 3 To Cells(3, Columns.Count).End(xlToLeft).Column
　　　　　myStart = DateValue(Left(.Cells(3, j), WorksheetFunction.Find("～", .Cells(3, j)) - 1))
　　　　　myEnd = DateValue(Mid(.Cells(3, j), WorksheetFunction.Find("～", .Cells(3, j)) + 1, 5))
　　　　　If myStart <= Date And myEnd >= Date Then
　　　　　　Exit For
　　　　　End If
　　　　Next j
　　　　Set c = .Cells(4, j) '//←4行目該当列//
　　　　Set r = .Cells(8, j) '//←8行目の該当列//

　　　　'//▼既存の四角形を消去//
　　　　For Each mySp In .Shapes
　　　　　If mySp.Top >= c.Top And mySp.Top + mySp.Height <= r.Top + r.Height Then
　　　　　　mySp.Delete
　　　　　End If
　　　　Next mySp

　　　　'//▼新たに四角形を挿入//
　　　　If WorksheetFunction.Weekday(Date,2) < 6 Then '//①//
　　　　　ActiveSheet.Shapes.AddShape(msoShapeRectangle, c.Left + (Day(Date) - Day(myStart)) * c.Width / 5, c.Top, _
　　　　　　c.Width / 5, r.Top - c.Top + r.Height).Select '//②//
　　　　　Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 0, 255) '//←「青」にしている//
　　　　　Selection.ShapeRange.Line.Visible = msoFalse '//←枠線なし//
　　　　　.Cells(3, j).Select
　　　　End If
　　End With
End Sub


※　①と②の部分が変わっています。
※　土日の場合は何も表示されません。

※　本日（投稿日）が土曜なので、細かい検証はできていませんが、
まずはこんな感じではどうでしょうか？m(_ _)m

No.3 回答者： tom04 回答日時： 2020/07/10 16:25

こんにちは！

全く違ったやり方になりますが・・・
移動ではなく、表示されているオートシェイプ（四角形）一旦消去し
あらたに挿入してみてはどうでしょうか？

操作するシート名は「Sheet1」とし、標準モジュールにしています。

Sub Sample1()
　Dim c As Range, r As Range
　Dim myStart As Date, myEnd As Date
　Dim j As Long
　Dim mySp As Shape

　　With Worksheets("Sheet1") '//←実際のシート名に！★//
　　　.Activate
　　　For j = 3 To Cells(3, Columns.Count).End(xlToLeft).Column
　　　　myStart = DateValue(Left(.Cells(3, j), WorksheetFunction.Find("～", .Cells(3, j)) - 1))
　　　　myEnd = DateValue(Mid(.Cells(3, j), WorksheetFunction.Find("～", .Cells(3, j)) + 1, 5))
　　　　　If myStart <= Date And myEnd >= Date Then
　　　　　　Exit For
　　　　　End If
　　　Next j
　　　Set c = .Cells(4, j) '//←4行目該当列//
　　　Set r = .Cells(8, j) '//←8行目の該当列//

　　　　'//▼既存の四角形を消去//
　　　　For Each mySp In .Shapes
　　　　　If mySp.Top >= c.Top And mySp.Top + mySp.Height <= r.Top + r.Height Then
　　　　　　mySp.Delete
　　　　　End If
　　　　Next mySp

　　　　'//▼新たに四角形を挿入//
　　　　ActiveSheet.Shapes.AddShape(msoShapeRectangle, c.Left + (Day(Date) - Day(myStart)) * c.Width / 7, c.Top, _
　　　　　　c.Width / 7, r.Top - c.Top + r.Height).Select
　　　　　Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 0, 255) '//←「青」にしている//
　　　　　Selection.ShapeRange.Line.Visible = msoFalse '//←枠線なし//
　　　　　.Cells(3, j).Select
　　End With
End Sub

これで↓の画像のような感じになります。
※　オートシェイプの幅は挿入したセル幅の　1/7　になっているはずです。
（画像では本日は金曜日なので、オートシェイプが挿入されているD列の右側部分が二日分になるはずです）

※　細かい検証はしていませんので、
お望みどおりにならなかったらごめんなさい。m(_ _)m

この回答へのお礼

tom04さん
ご回答ありがとうございます！
すみません、やりたいことの説明が文章では難しくてうまくお伝えすることができなかったのですが、週の行の見出しが「7/6月～7/10金」となっているように、金曜なら列の右端の方にバーを移動させたい（土日のスペースを除外したい）という要件でどうすれば良いのか悩んでいた感じになります。
ですが、VBA初心者の私にはtom04さんの記述方法が「こんなやり方もあるのか！」ととても参考になりました！
ありがとうございます。m(_ _)m

お礼日時：2020/07/11 16:25

No.1 回答者： めぐみん_ 回答日時： 2020/07/10 11:23

検証してないので違ったらモニターの電源切ってみなかったことにしてください。

Count = ToDay - StartDay - IIf(WorksheetFunction.Weekday(Date, 2) < 6, 0, WorksheetFunction.Weekday(Date, 2) - 5)

に差し替えたらどうでしょうか？

https://support.microsoft.com/ja-jp/office/weekd …

にて土日の場合その結果から－５をすれば土曜なら１、日曜なら２戻ると思うのですが。