エクセルVBA初心者です。
今ガントチャートを作っているのですが、添付の図のように青いバーが今日を表す図形で、列1つが週単位になっています。日では無く週単位にしたくてこのようになっています。
ネットで検索しつつ自力で「ブックを開いたら本日の位置にバーが移動する」こと自体は実現できたのですが、列1つを7で割って移動させているので土日も含めた均等な幅でバーが動いていく状態です。
添付の図は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 '1日の移動量
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ベストアンサー
- 回答日時:
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 (1日の移動量)分を補正してあげれば良いような。。。未検証で申し訳ないですが。
めぐみんさん
いつもお世話になっています!
めぐみんさんの記述を試してみてうまくいかなかったのですが考え方はとても参考になりまして、その後は自力で無事達成することができました(関数をうまく扱えていなくて冗長ですが‥)。
ありがとうございました!
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
No.6
- 回答日時:
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
No.4
- 回答日時:
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
- 回答日時:
こんにちは!
全く違ったやり方になりますが・・・
移動ではなく、表示されているオートシェイプ(四角形)一旦消去し
あらたに挿入してみてはどうでしょうか?
操作するシート名は「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
No.1
- 回答日時:
検証してないので違ったらモニターの電源切ってみなかったことにしてください。
Count = ToDay - StartDay - IIf(WorksheetFunction.Weekday(Date, 2) < 6, 0, WorksheetFunction.Weekday(Date, 2) - 5)
に差し替えたらどうでしょうか?
https://support.microsoft.com/ja-jp/office/weekd …
にて土日の場合その結果から-5をすれば土曜なら1、日曜なら2戻ると思うのですが。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) いつもお世話になっております、VBAで教えて頂きたいのですが 2 2022/05/05 22:20
- Excel(エクセル) エクセルで同じ数字同士を自動で線で結ぶVBAを教えてください 6 2022/04/26 23:13
- Excel(エクセル) 日付で矢印マクロ 4 2023/07/25 16:47
- Visual Basic(VBA) QRコード作成マクロについて 3 2022/11/26 16:55
- Visual Basic(VBA) 改行ごとに行を追加し、数量を分割 4 2023/07/11 16:39
- Visual Basic(VBA) 【ご教示ください】VBAの記述方法がわかりません。 2 2022/08/12 21:28
- Visual Basic(VBA) マクロVBA 1シートをまとめる 閉じ方 初心者 SOS! 1 2022/06/17 14:54
- Excel(エクセル) 【マクロ】スクショ印刷がうまく動かない件 5 2022/12/06 17:37
- Visual Basic(VBA) VBAで質問ですが、皆さんはどの様に導き出しているのでしょうか? 6 2022/05/03 21:53
- Excel(エクセル) VBAで組み合わせ算出やCOUNTIFSの処理を高速化したいです。 4 2022/04/07 02:38
このQ&Aを見た人はこんなQ&Aも見ています
-
新NISA制度は今までと何が変わる?非課税枠の拡大や投資対象の変更などを解説!
少額から投資を行う人のための非課税制度であるNISAが、2024年に改正される。おすすめの銘柄や投資額の目安について教えてもらった。
-
エクセルで日にちを入力すると矢印が自動的に引かれるとか。
Excel(エクセル)
-
【エクセル】今日の日付に赤枠をつけたい【Excel】
Excel(エクセル)
-
日付を入力しカレンダーの該当する日に印をつけたい
Excel(エクセル)
-
-
4
ファイルのオープン時に今日の日付にジャンプ
Excel(エクセル)
-
5
エクセル2016で時間を入力して線で反映させる方法について
Excel(エクセル)
-
6
日付入力→指定のセルの色を塗りつぶし
Excel(エクセル)
-
7
エクセルでオートシェイプをデータによって移動できますか?
Windows Vista・XP
-
8
Excelの条件付き書式設定の太い罫線
Excel(エクセル)
-
9
エクセルVBAで、条件に一致するセルへ移動
Excel(エクセル)
-
10
あるセルに色を付けた時、別のセルにも同じ色が付く
Excel(エクセル)
-
11
エクセルで図形を連動させたい
Excel(エクセル)
-
12
エクセルで、日付を入力すると、別のセルに文字を自動的に表示させるようにするには。
Excel(エクセル)
-
13
エクセルで条件をつけて図形を表示する方法を教えてください。例えば、セルA1に入力された数値が100以
Excel(エクセル)
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
エクセルで二つの数字の小さい...
-
エクセルで最初のスペースまで...
-
PowerPointで表の1つの列だけ...
-
2つのエクセルのデータを同じよ...
-
EXCELで 一桁の数値を二桁に
-
「B列が日曜の場合」C列に/...
-
エクセルで文字が混じった数字...
-
エクセルの項目軸を左寄せにしたい
-
Excelで半角の文字を含むセルを...
-
エクセル(勝手に太字になる)
-
VBAで文字列を数値に変換したい
-
エクセル 文字数 多い順 並...
-
エクセルの列を範囲選択しての...
-
50人を数回、グループ分けする...
-
エクセルで、列の空欄に隣の列...
-
オートフィルターをかけ、#N/A...
-
Excel、市から登録している住所...
-
【VBA】特定列に文字が入ってい...
-
エクセルのセル内の文字の一部...
-
エクセルの並び変えで、空白セ...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
PowerPointで表の1つの列だけ...
-
エクセルで二つの数字の小さい...
-
エクセル 同じ値を探して隣の...
-
2つのエクセルのデータを同じよ...
-
エクセルで最初のスペースまで...
-
エクセル 文字数 多い順 並...
-
エクセルの項目軸を左寄せにしたい
-
エクセル(勝手に太字になる)
-
EXCELで 一桁の数値を二桁に
-
Excel、市から登録している住所...
-
VBAで文字列を数値に変換したい
-
「B列が日曜の場合」C列に/...
-
Excelで半角の文字を含むセルを...
-
EXCEl VBA
-
エクセルの並び変えで、空白セ...
-
VBAで、サブフォルダにある複数...
-
エクセルで文字が混じった数字...
-
エクセルの表から正の数、負の...
-
エクセルの列を範囲選択しての...
-
エクセル 時間帯の重複の有無
おすすめ情報