Excel VBAでカレンダーを作成する方法

このQ&Aのポイント
  • Excel VBAを使用して、指定した年月のカレンダーを作成する方法について説明します。
  • 入力ボックスで指定した年月の日付情報を取得し、カレンダーの表示範囲を設定します。
  • カレンダーには、指定した月の日付が表示され、他の月の日付はグレーアウトされます。また、指定した日付から試験までの日数を表示する機能もあります。
回答を見る
  • ベストアンサー

私が変更したいようにできるか、ぜひお力添えをお願いします。

Sub Prep_Calendar() Dim 入力 As String Dim 開始日 As Date, 日付 As Date Dim 今月 As Integer Dim i As Integer, j As Integer 入力 = InputBox("年月を yyyy/m の形式で入力") If IsDate(入力) = True Then 開始日 = CDate(入力) Else MsgBox ("正しい日付を入力") Exit Sub End If Range("B2").Value = Year(開始日) Range("D2").Value = Month(開始日) 今月 = Month(開始日) 日付 = 開始日 - Weekday(開始日) + 1 For i = 1 To 11 Step 2 For j = 1 To 7 If 今月 = Month(日付) Then Cells(i + 3, j + 1).Value = Day(日付) Cells(i + 3, j + 1).Interior.ColorIndex = 2 Cells(i + 4, j + 1).Interior.ColorIndex = 2 Else Cells(i + 3, j + 1).Value = "" Cells(i + 3, j + 1).Interior.ColorIndex = 35 Cells(i + 4, j + 1).Interior.ColorIndex = 35 End If 日付 = 日付 + 1 Next Next End Sub まず、インプットボックスにて2003/9と入力すると、B2に2003、D2に9と入力されます。 元から作成してあるエクセルの3列目には、B3からC3,D3…と、日月火…土と入っております。 B4からH5までがカレンダーになっており、当月分以外の欄は、緑色でセルに色がつきます。 1行飛ばしで日付が入力されるようになっているのですが、これを1行飛ばしではなく、3行飛ばしに変更したいです。 また、試験日が分かっていたら、その日から逆算させて日付の最終行に「試験まであと○日」などと表示ができたら文句ないです。 初心者です。 意味不明点など、補足要求をお願いします。

noname#4742
noname#4742

質問者が選んだベストアンサー

  • ベストアンサー
  • imogasi
  • ベストアンサー率27% (4737/17068)
回答No.1

Sub Prep_Calendar() Dim 入力 As String Dim 開始日 As Date, 日付 As Date Dim 今月 As Integer Dim i As Integer, j As Integer Cells.Clear 入力 = InputBox("年月を yyyy/m の形式で入力") s = InputBox("試験日yyyy/mm/dd=") 試験日 = DateValue(s) ' MsgBox 試験日 If IsDate(入力) = True Then 開始日 = CDate(入力) Else MsgBox ("正しい日付を入力") Exit Sub End If Range("B2").Value = Year(開始日) Range("D2").Value = Month(開始日) 今月 = Month(開始日) 日付 = 開始日 - Weekday(開始日) + 1 For i = 1 To 16 Step 3 For j = 1 To 7 If 今月 = Month(日付) Then Cells(i + 3, j + 1).Value = Day(日付) Cells(i + 3, j + 1).Interior.ColorIndex = 2 Cells(i + 4, j + 1).Interior.ColorIndex = 2 Cells(i + 5, j + 1).Interior.ColorIndex = 2 d = DateSerial(Range("b2"), Range("d2"), Day(日付)) If 試験日 - d >= 0 Then Cells(i + 5, j + 1) = 試験日 - d Cells(i + 5, j + 1).Font.Color = vbRed End If Else Cells(i + 3, j + 1).Value = "" Cells(i + 3, j + 1).Interior.ColorIndex = 35 Cells(i + 4, j + 1).Interior.ColorIndex = 35 Cells(i + 5, j + 1).Interior.ColorIndex = 35 End If 日付 = 日付 + 1 Next Next End Sub

noname#4742
質問者

お礼

うまく行きました。 質問の意図もしっかり読み取っていただき、本当にありがとうございました。 またのご活躍を楽しみにしております。

関連するQ&A

  • ExcelのVBAで質問です。

    以下のようなシートがあります。 A列  B列  C列  D列  E列  F列  G列  H列 NO  名前  確認 日付1 日付2  確認 日付1 日付2 6行目からデータを入れる予定です。 C列には○印を入力します。 C列~E列までデータが入った行は、 F列~H列まで同じ処理をします。 (セルの背景色を変えます。) 以後同じことを列方向で繰り返します。 以下のようなVBAを組みましたが、 ○の個数を数える部分でエラーがでます。 Private Sub Worksheet_Change(ByVal Target As Range) Dim staff As String Dim kakunin As String Dim date1 As Date Dim date2 As Date Dim i As Long Dim j As Long Dim cnt As Long '100件分ループ For i = 6 To 105 '○の数をカウント cnt = WorksheetFunction.CountIf(ActiveSheet.Range(Cells(i, 2), Cells(i, 256)), "○") 'jとは確認の列番号のこと j = 3 * cnt staff = Cells(i, 2) kakunin = Cells(i, j) date1 = Cells(i, j + 1) date2 = Cells(i, j + 2) 'スタッフ名が入力されたら If staff = "" Then Range(Cells(i, j), Cells(i, j + 50)).Interior.ColorIndex = 15 Else Cells(i, j).Interior.ColorIndex = xlNone '○が入力されたら If kakunin = "○" Then Range(Cells(i, j + 1), Cells(i, j + 2)).Interior.ColorIndex = xlNone Else Range(Cells(i, j + 1), Cells(i, j + 2)).Interior.ColorIndex = 15 End If If Cells(i, j + 1) <> "" And Cells(i, j + 2) <> "" Then Cells(i, j + 3).Interior.ColorIndex = xlNone End If End If Next i End Sub ご教授いただけたら、幸いです。 よろしくお願いいたします。

  • 判定してセルを塗りつぶすマクロについて

    判定してセルを塗りつぶすマクロについて教えて下さい。 現在下記のようなマクロがあります。 Sub オニオン判定() Dim i As Integer, j As Integer, r As Integer Dim k As Double Range(Cells(17, 9), Cells(26, 14)).Interior.ColorIndex = 0 Range(Cells(30, 9), Cells(39, 14)).Interior.ColorIndex = 0 k = Cells(5, 2) 'B5セルの値 For j = 9 To 14 For i = 17 To 26 For r = 30 To 39 If Abs(Cells(i, j).Value - Cells(r, j).Value) <= 0.05 Then Cells(r, j).Interior.Color = vbYellow Cells(i, j).Interior.Color = vbYellow End If Next  Next   Next End Sub 対象のIf Abs(Cells(i, j).Value - Cells(r, j).Value) <= 0.05 Then で、それぞれ見比べて、0.05以上のずれがあるとセルが塗りつぶされないというマクロなのですが これを、If Abs(Cells(i, j).Value - Cells(r, j).Value) = 0 Thenという条件も追加して その時はセルを青に塗りつぶし、逆に0.05以上のずれがあるセルは赤に塗りつぶす。 みたいなマクロを書きたいです。 If Abs(Cells(i, j).Value - Cells(r, j).Value) = 0 Thenは一度追加してみましたが 上手く機能しませんでした。 やりたい事 ・数値が動いているけど、0.05以内の時は黄色 ・数値変動が0の場合は青 ・数値変動が0.05以上の場合は赤 です。 宜しくお願いします。

  • ExcelVBAで、選択範囲内で同じ値が入力されたセルを調べる

    選択範囲内(縦一列)で同じ値が入力されたセルの色を黄色にするプログラムを作りました。 Sub 選択範囲内で同じ値が入力されたセルを調べる_縦() Dim startrow As Byte Dim lasrow As Byte Dim i As Long Dim j As Byte Dim atai If TypeName(Selection) <> "Range" Then Exit Sub startrow = ActiveCell.Row '最初のセルの列番号を取得 lasrow = Selection.Rows(Selection.Rows.Count).Row '最終列番号を取得 '同じ値が入力されているセルを黄色にする For i = startrow To lasrow - 1 If ActiveSheet.Cells(i, ActiveCell.Column).Interior.ColorIndex = xlNone Then atai = ActiveSheet.Cells(i, ActiveCell.Column).Value For j = i + 1 To lasrow If atai = ActiveSheet.Cells(j, ActiveCell.Column).Value Then ActiveSheet.Cells(i, ActiveCell.Column).Interior.ColorIndex = 6 ActiveSheet.Cells(j, ActiveCell.Column).Interior.ColorIndex = 6 End If Next End If Next End Sub 但し、上記のプログラムでは選択範囲内に結合セルがあるとエラーになってしまいます。 どなたか、解決方法をご教授頂けませんでしょうか? 宜しくお願い致しますm(._.)m

  • EXCEL セルをコピペすると画面がフリーズする

    お世話になります excelシート イベントでセルの値が変わった時にマクロが実行されるVBAを作成していて、 1行毎の入力作業はうまくいくのですが、式の入っていないセルを複数行をコピペ、 例えばA,Bセルの値が同じものが5件ほどあった場合、最初の入力のものをしたにドラッグして 貼り付けると、画面がフリーズして強制終了せざる負えなくなります。 エラーを回避する方法をご教示お願いいたします。以下VBAの内容です。 Dim sh1 As Worksheet Dim i As Integer Private Sub Worksheet_Calculate() 'detailに指標をセット i = 9 シートをworkエリアにセット Set sh1 = Worksheets(4) 'カードルシート,2ページ(予備)まで指標を回す For i = 9 To 66 '画面ちらつき防止 Application.ScreenUpdating = False '2ページ(予備)目ヘッダーは処理しない If i < 33 Or i > 41 Then 'サンプル番号が入力されている時 If sh1.Cells(i, "E") <> "" Then 'サンプル年月が入力されている時 If IsError(sh1.Cells(i, "K")) <> True Then '基準年月 >= サンプル年月 の時 If sh1.Cells(7, "O") >= sh1.Cells(i, "K") Then '次回サンプル年月 <= 当年月 の時 If sh1.Cells(i, "Q") <= sh1.Cells(8, "O") Then sh1.Cells(i, "M") = "出荷禁止" '該当行を赤色で塗りつぶし With sh1 .Cells(i, "A").Interior.ColorIndex = 3 .Cells(i, "B").Interior.ColorIndex = 3 .Cells(i, "C").Interior.ColorIndex = 3 .Cells(i, "D").Interior.ColorIndex = 3 .Cells(i, "E").Interior.ColorIndex = 3 .Cells(i, "F").Interior.ColorIndex = 3 .Cells(i, "G").Interior.ColorIndex = 3 .Cells(i, "H").Interior.ColorIndex = 3 .Cells(i, "I").Interior.ColorIndex = 3 .Cells(i, "J").Interior.ColorIndex = 3 .Cells(i, "K").Interior.ColorIndex = 3 .Cells(i, "L").Interior.ColorIndex = 3 .Cells(i, "M").Interior.ColorIndex = 3 End With Else '次回サンプル年月 <= 当年月 でない時 sh1.Cells(i, "M") = "OK" End If End If End If Else '該当行を無色で塗りつぶし With sh1 .Cells(i, "A").Interior.ColorIndex = 0 .Cells(i, "B").Interior.ColorIndex = 0 .Cells(i, "C").Interior.ColorIndex = 0 .Cells(i, "D").Interior.ColorIndex = 0 .Cells(i, "E").Interior.ColorIndex = 0 .Cells(i, "F").Interior.ColorIndex = 0 .Cells(i, "G").Interior.ColorIndex = 0 .Cells(i, "H").Interior.ColorIndex = 0 .Cells(i, "I").Interior.ColorIndex = 0 .Cells(i, "J").Interior.ColorIndex = 0 .Cells(i, "K").Interior.ColorIndex = 0 .Cells(i, "L").Interior.ColorIndex = 0 .Cells(i, "M").Interior.ColorIndex = 0 .Cells(i, "M") = "" End With End If End If Next i End Sub

  • 御願いします

    Sheet4にある表から同じ値を検索するマクロです。 同じ値があったセルの背景を黄色に,ただし空白セルは空白の ままにしたいのですが。 うまく動きません。 初めてマクロを立てました。 どうか解決にお力かして下さい。 ********************************************************* Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim RetRange As Range Dim lngYCnt As Long Dim intXCnt As Integer lngYCnt = Worksheets("Sheet4").UsedRange.Rows.Count intXCnt = Worksheets("Sheet4").UsedRange.Columns.Count For i = 1 To lngYCnt For j = 1 To intXCnt If Cells(i, j).Value = "" Then Cells(i, j).Interior.ColorIndex = xlNone Else Set RetRange = Selection.Find(What:=Cells(i, j).Value, _ after:=ActiveCell, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, _ SearchDirection:=xlNext) If Not RetRange Is Nothing Then If RetRange.Address <> Cells(i, j).Address Then RetRange.Interior.ColorIndex = 36 Cells(i, j).Interior.ColorIndex = 36 End If Next Next End If ErrorHandler: End Sub

  • マクロ 検索範囲を修正したい 1つ置きのセルで

    前に以下のマクロをここで教えていただきました。このときはB列からF列の範囲でお願いしたのですが、F列~AG列の1つ置きのセル(G、I、K・・・列)で検索したいです。どう修正したらよいですか?初心者なので調べても分からなかったので教えてください。 Sub Sample1() 'この行から Dim i As Long, j As Long, vL vL = InputBox("検索値を入力してください。") Application.ScreenUpdating = False Cells.Interior.ColorIndex = xlNone For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row For j = 2 To 5 With Cells(i, j) If .Value <> "" And .Value >= vL - 3 And .Value <= vL + 3 Then .Interior.ColorIndex = 36 End If End With Next j Next i Application.ScreenUpdating = True End Sub 'この行まで

  • マクロ 色が思うように、表示できない

     下記のようなコードで部品の管理をしています。条件が多くて少し複雑になっています。 とりあえずは、うまくできました。J列の結果だけが、うまくできません。 但し、J列の結果が(38はローズ )の表示がうまくいきません。(6の黄色)になってしまいます。 要するに、J列の結果が不がローズ色で、合が白色で、欠が薄いオレンジ色になればよいということなのです。 原因が分からず困ってしまって、お聞きする次第です。回答して頂けるものでしようか。 ご教授下されば幸いに存じます。よろしくお願いします。  Macro2 Macro マクロ記録日 : ' Sheets("sheet1").Select Columns("A:J").Select Selection.Copy Sheets("sheet2").Select Columns("A:J").Select ActiveSheet.Paste Application.CutCopyMode = False Selection.Sort Key1:=Range("H2"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _ :=xlPinYin, DataOption1:=xlSortNormal Dim i As Long, LastRow As Long LastRow = Cells(Rows.Count, "A").End(xlUp).Row Range("J2:J" & LastRow).ClearContents '← E2:Jにすると、欠に全部なります、この設定もおかしいように思いますが? Range("E2:J" & LastRow).Interior.ColorIndex = 0 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual '文言の詳細について '部品名と詳細-------------------------------------略称            'ghyu--------------------------------------←E列   'klub---------------------------------------←F列  'llpo----------------------------------------←G列  '合計個数(合計)-------------------------←H列  合計   '数量順位---------------------------------←I列   順位 '合格・不合格(合・不)欠品(欠)-----←J列  合・不・欠 If Cells(i, "E") >= 1 And Cells(i, "E") < 20 Then Cells(i, "E").Interior.ColorIndex = 6 ' 6は  黄色 End If If Cells(i, "F") >= 1 And Cells(i, "F") < 6 Then Cells(i, "F").Interior.ColorIndex = 6 ' 6は  黄色  End If If Cells(i, "F") >= 6 And Cells(i, "F") < 10 Then Cells(i, "F").Interior.ColorIndex = 34 '34は  淡い青色 End If If Cells(i, "G") >= 1 And Cells(i, "G") < 10 Then Cells(i, "G").Interior.ColorIndex = 6 ' 6は  黄色  End If If Cells(i, "H") >= 1 And Cells(i, "H") <= 49 Then Cells(i, "H").Interior.ColorIndex = 4 ' 4は  うぐいす色  End If If Cells(i, "J") >= "不" Then Cells(i, "J").Interior.ColorIndex = 38 '38は ローズ    End If If Cells(i, "J") >= "合" Then Cells(i, "J").Interior.ColorIndex = 2 ' 2は  白色  End If For j = 5 To 9 'D-F If Cells(i, j).Value = 0 Then Cells(i, j).Interior.ColorIndex = 3 '3は    赤色        ElseIf Cells(i, j).Value = "欠" Then Cells(i, j).Interior.ColorIndex = 45 '45は  薄いオレンジ色     End If Next j For k = 5 To 9 'G-I If Cells(i, j).Value = "欠" Then Cells(i, j).Interior.ColorIndex = 45 '45は  薄いオレンジ色   End If Next k Next i Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub

  • VBAで教えてください。

    下のようなコードを見つけて勉強しています。 簡単な応用ができません・・・。 P1=今日の日付 G=訪問日 I=御礼の手紙を書いた日付 として、 訪問日が過ぎていて、御礼の手紙が未入力なら“超過があります”とメッセージと色で知らせるものですが、 下のような感じで P1=今日の日付 I=御礼の手紙を書いた日付 K=返事が来た日付 御礼の手紙を書いた日付から20日が過ぎてもK列に返事が来た 日付が入力がないものには ・“返事がありません”とメッセージ ・薄い灰色に行を塗る というようにしたいのですが、教えていただけないでしょうか。 自分では、+20という表現をどのように書いたらいいのかというとこ ろで躓いてしまいました。 どうぞ宜しくお願いします。 Sub test () Dim SH As Worksheet Dim i As Integer Dim s As String Set SH = Worksheets("表") s = "超過はありません。" i = 1 Do Until SH.Cells(i + 3, "A").Value = "" If SH.Cells(i + 3, "G").Value < SH.Range("P1") And _ SH.Cells(i + 3, "I").Value = "" Then SH.Cells(i + 3, "A").Resize(, 16).Interior.ColorIndex = 3 s = "超過があります。" End If i = i + 1 Loop MsgBox s End Sub

  •  条件付き書式での色付けで以下のコードを教えて頂いたんですが、色付けを

     条件付き書式での色付けで以下のコードを教えて頂いたんですが、色付けを 適用する範囲をどうやって変更すればいいのでしょうか? もしよろしければ、範囲の変更の仕方と、コードの意味を教えて頂けますか? めんどうですがよろしくお願いします・・・。 Private Sub Worksheet_SelectionChange(ByVal Target As Range) Columns(3).Interior.ColorIndex = xlNone Dim i, j As Long For i = 1 To Cells(Rows.Count, 3).End(xlUp).Row For j = 1 To Cells(Rows.Count, 6).End(xlUp).Row If Cells(i, 3) = Cells(j, 6) Then Cells(i, 3).Interior.ColorIndex = Cells(j, 7).Interior.ColorIndex End If Next j Next i End Sub

  • VBA マクロについて

    自作のカレンダーに自動で日付を判定、入力してくれる ロジックを作っていたのですが、 2、4、6、9、11月以外は31日分表示されるはずが。。。 表示されませんでした。 恐らくロジックがおかしくて i=31 が通っていないものと 思われますが、ちょっとよく分かりません。 初心者で低レベルな質問ですけど、どなたかお願いします。 Sub AutoCarender() '自動でカレンダーの日付を入力するプログラム Dim month, i As Integer '表示させたい月 month = 3 If (month = 2) Then i = 28 ElseIf (month = 4 Or 6 Or 9 Or 11) Then i = 30 Else i = 31 End If Dim tate, yoko As Integer Dim week As Integer week = (Weekday(2009 / month / 1, 2)) yoko = Choose(week, 1, 3, 5, 7, 9, 11, 13) tate = 3 For j = 1 To i '"シートの名前"を指定 Worksheets("Sheet1").Cells(tate, yoko).Value = j yoko = yoko + 2 If (yoko > 13) Then yoko = 1 tate = tate + 2 End If Next End Sub

専門家に質問してみよう