• 締切済み

エクセルのVBAで質問があります。

現在自分はカレンダーを作成していて、カレンダーに祝日を入れたいと思っています そこで これを if文もしくはselectcase どっちを使ったら楽か教えてもらいたいです Sub MakeCalendar(hi As Date) Dim i As Integer 'カレンダーにセットする日付 Dim g As Integer '日付をセットする行番号 Dim r As Integer '日付をセットする列番号 Dim lastDay As Integer '作成するカレンダーの月末 g = 2 'その月の開始曜日を算出 r = Weekday(DateSerial(Year(hi), Month(hi), 1), vbSunday) '指定された日付の翌月1日をもとて、日付の前の日を計算する lastDay = Day(DateSerial(Year(hi), Month(hi) + 1, 1) - 1) For i = 1 To lastDay 'iに日付の設定 Cells(g, r).Value = i If r = 7 Then r = 1 '戻して g = g + 1 '1行下に書く Else r = r + 1 '1列→に移動する End If Next End Sub Sub test() Range("A2:G7").Value = "" 'A2~G2にカレンダー表示 MakeCalendar Range("I2").Value 'I2に日付を入力する End Sub Sub test() Range("A2:G7").Value = "" 'A2~G2にカレンダー表示 MakeCalendar Range("I2").Value 'I2に日付を入力する End Sub このようなマクロを組んでいまして、祝日(ゴールデンウィークなど)を赤で塗りつぶすような物を考えています。 VBAは初心者でまだあまりわかっていないので、ご教授ください

みんなの回答

  • kagakusuki
  • ベストアンサー率51% (2610/5101)
回答No.1

 VBAではなく、関数を使った方法になりますが、以下の様な方法は如何でしょうか?  今仮に、カレンダーを表示させるシートのシート名がSheet1であるものとします。  まず、以下の参考URLのページの回答No.4に記されている方法に従って、休日シートに祝日と振替休日の一覧表を作成して下さい。 【参考URL】  質問No.8336981 エクセルの関数とオフィス2007-OKWave   http://okwave.jp/qa/q8336981.html  次に、Sheet1のB4セルに次の関数を入力して下さい。 =IF(ISNUMBER(1/(YEAR((TEXT($B$2,"yyyy年m月")&"1日")+0)>1904)),IF(ISNUMBER((TEXT($B$2,"yyyy年m月")&COLUMNS($B:B)-WEEKDAY((TEXT($B$2,"yyyy年m月")&"1日")+0)+1+(ROWS($4:4)-1)*7&"日")+0),(TEXT($B$2,"yyyy年m月")&COLUMNS($B:B)-WEEKDAY((TEXT($B$2,"yyyy年m月")&"1日")+0)+1+(ROWS($4:4)-1)*7&"日")+0,""),"")  次に、Sheet1のB4セルの書式設定の表示形式を[ユーザー定義]の d に設定して下さい。  次に、以下の操作を行って、B4セルに条件付き書式を設定して下さい。 Sheet1のB4セルを選択   ↓ [ホーム]タブをクリック   ↓ 現れた「スタイル」グループの中にある[条件付き書式]ボタンをクリック   ↓ 現れた選択肢の中にある[ルールの管理]をクリック   ↓ 現れた「条件付き書式ルールの管理」ダイアログボックスの中にある[新規ルール]ボタンをクリック   ↓ 現れた「新しい書式ルール」ダイアログボックスの[数式を使用して、書式設定するセルを決定]をクリック   ↓ 「次の数式を満たす場合に値を書式設定」と記されている欄に =AND(ISNUMBER(B4),COUNTIF(INDIRECT("休日!B:B"),B4)) と入力  尚、ExcelのバージョンがExcel2007以降(Excel2007も含む)の場合には、 =AND(ISNUMBER(B4),COUNTIF(休日!$B:$B,B4)) でも可   ↓ 「新しい書式ルール」ダイアログボックスの[書式]ボタンをクリック   ↓ 現れた「セルの書式設定」ダイアログボックスの[塗りつぶし]タブをクリック   ↓ 現れた「背景色」欄の色のサンプルの中にある赤色の四角形をクリック   ↓ 「セルの書式設定」ダイアログボックスの[OK]ボタンをクリック   ↓ 「新しい書式ルール」ダイアログボックスの[OK]ボタンをクリック   ↓ 「条件付き書式ルールの管理」ダイアログボックスの中にある[適用]ボタンをクリック   ↓ 「条件付き書式ルールの管理」ダイアログボックスの中にある[OK]ボタンをクリック  次に、Sheet1のB4セルをコピーして、Sheet1のB4~H9の範囲に貼り付けて下さい。  次に、Sheet1のB4~B9のセルの書式設定[塗りつぶし]を赤に、同じくH4~H9のセルの書式設定[塗りつぶし]を青に設定して下さい。  以上で準備は完了で、後はSheet1のB2セルに 2013年11月 或いは 平成25年11月 等の様に年と月を併せて入力しますと、カレンダーが自動的に表示されます。

関連するQ&A

  • エクセル2019 VBAについて

    エクセル2019でVBAを使いコピーペーストの勉強中です、次の箇所(Dim i As integr)で、ユーザー定義型は定義されていませんと指摘されて止まってしまします、Sheet("データ")には3行のデータは入っています、VBA初心者のため、この後が、なかなか前に進めません、どうかよろしくおねがいします。 ********************************** Sub 練習() Dim s1 As Worksheet: Set s1 = Worksheets("請求書") Dim s2 As Worksheet: Set s2 = Worksheets("データ") Dim r1 As Integer: r1 = 18 Dim r2 As Integer: r2 = 2 { Dim i As integr } For i = 0 To 2 s1.Range(s1.Cells(r1 + i, 1), s1.Cells(r1 + i, 3)).Value = s2.Range(s2.Cells(r2 + i, 2), s2.Cells(r2 + i, 4)).Value s1.Cells(r1 + i, 4).Value = s1.sells(r1 + i, 2).Value * s1.Cells(r1 + i, 3).Value Next End Sub ***************************************

  • EXCEL VBA

    EXCEL VBAで空白行が現れたら「小計」の文字を入力したいと思い以下のように記述しましたが、うまくいきません。どこがおかしいのか教えてください。 宜しくお願いします。 Sub write小計() Dim i As Integer Dim rowcnt As Integer rowcnt = Cells(1, 1).CurrentRegion.Rows.Count Range("B1").Select For i = 1 To rowcnt If Cells(i, 2).Value = "" Then Value = "小 計" ActiveCell.Offset(1).Select Next i End Sub

  • Excel2010 VBA 条件色付け

    Sub sample() Dim r As Range For Each r In Range("q6:q30") If myIsNumeric(r) Then r.Offset(0, 1).Value = "数字" Else r.Offset(0, 1).Value = "文字" End If Next End Sub Function myIsNumeric(Target As Range) Dim r As Range Dim buf, tmp Dim flg As Boolean Dim i As Integer buf = Target For i = 1 To Len(buf) tmp = Mid(buf, i, 1) If IsNumeric(tmp) Then flg = True Exit For End If Next myIsNumeric = flg End Function を数字が入ってたら塗りつぶさないで、 数字が入ってなかったら塗りつぶすように直したいです。 あああ→塗る あああ1-1→塗らない 住所→塗る 住所12→塗らない

  • エクセルVBAのイベントで質問です。

    ダブルクリックイベントで、G12:G31の範囲の文字列をB10:B27の範囲(最下行)に入れていくものを使っていますが、新たにH12:H31にある文字列もダブルクリックするとC10:C27の範囲(最下行)に入れていけるようにしたいと思います。 どのようにすればいいでしょうか。 ご存知の方いらっしゃればお教えいただけると助かります。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, _ Cancel As Boolean) Dim i As Long Dim flg As Boolean If Intersect(Target, Range("G12:G31")) Is Nothing Then Exit Sub If IsEmpty(Target.Value) Then Exit Sub With Worksheets("シートA") For i = 10 To 27 If .Range("B" & i).Value = "" Then .Range("B" & i).Value = Target.Value flg = True Exit For End If Next i If flg = False Then MsgBox .Name & " がいっぱいです。" End If End With Cancel = True End Sub

  • エクセルVBAでTransposeの不思議

    MS Officeのエクセル2000です。 下記Sub test01はRange("A1:I1")に文字列を入力し、一旦配列に取り込んでからワークシートに貼り付けるものです。 試験用のコードですので意味はありません。 このコードで255文字まではまったく問題はありません。 ところが、256文字以上の場合、横に貼り付けは問題ないのですが、 Transposeで縦に変換すると型が一致しません。(Error 13)となります。 どうしてでしょうか? 試行錯誤の結果、Sub test02のように一旦横に貼ったデータをコピーしてTransposeして貼り付けるのは大丈夫のようですので不思議でしょがありません。 またこの方法は列数256より要素が多い配列には使えないので解決策にはなりません。 ご教示くださいませ。 Sub test01() Dim myAr As Variant Dim i As Integer, n As Integer n = 256 '文字数 With ActiveSheet .UsedRange.ClearContents For i = 1 To 9 .Cells(1, i).Value = Application.Rept(Left(.Cells(1, i).Address(0, 0), 1), n) Next myAr = .Range("A1:I1").Value .Range("A3").Resize(, UBound(myAr, 2)).Value = myAr .Range("A5").Resize(UBound(myAr, 2)).Value = Application.Transpose(myAr) '256文字の場合エラー End With End Sub Sub test02() Dim myAr As Variant Dim i As Integer, n As Integer n = 256 '文字数 With ActiveSheet .UsedRange.ClearContents For i = 1 To 9 .Cells(1, i).Value = Application.Rept(Left(.Cells(1, i).Address(0, 0), 1), n) Next myAr = .Range("A1:I1").Value .Range("A3").Resize(, UBound(myAr, 2)).Value = myAr .Range("A3").Resize(, UBound(myAr, 2)).Copy .Range("A5").PasteSpecial Paste:=xlValues, Transpose:=True '256文字の場合もOK Application.CutCopyMode = False End With End Sub

  • EXCEL VBA で,プログラムが動かない.

    EXCEL2000のVBAでプログラムを組みました.(下に記す) 数千行に及ぶ数字のデータがあるのですが,20行に1回だけ,いらないデータが3行出てきます.その3行を削除していくプログラムです.Rangeのところで行を選んで欲しいのに,p列とq列を選んでしまうようです.RangeをRowsに変えたらエラーが出ました.こういう場合はどのように書けばいいのでしょうか.誰か教えてください.お願いします. Sub 削除() '20行ごとに入っている3行を削除していく. Dim i As Integer Dim p As Integer Dim q As Integer p = 21           'pの初期値は21 For i = 1 To 500 q = p + 2 r = "p:q" Range(r).Select Selection.Delete shift:=xlUp p = p + 20 Next i End Sub

  • excel vbaでの質問になります

    このようなマクロを作成したのですが、セルに数式が入れてあると、どうしてもその下の空白の行に値を入力されてしまいます。 数式が入っているセルにもそのままセルに値を入れたいのですが・・ 宜しくお願いします。 Dim wb1 As Worksheet, r1 As Range Dim N As Integer, i As Integer Dim mycount As Long   Set wb1 = ThisWorkbook.Worksheets("請求書") mycount = Range("B111").CurrentRegion.Rows.Count Cells(111 + mycount, 2).Select ActiveCell.Offset(0, 0).Value = wb1.Range("C60").Value ActiveCell.Offset(0, 1).Value = wb1.Range("C61").Value ActiveCell.Offset(0, 12).Value = wb1.Range("C66").Value ActiveCell.Offset(0, 13).Value = wb1.Range("C74").Value ActiveCell.Offset(0, 14).Value = wb1.Range("C75").Value ActiveCell.Offset(0, 15).Value = wb1.Range("C84").Value ActiveCell.Offset(0, 16).Value = wb1.Range("C85").Value ActiveCell.Offset(0, 20).Value = wb1.Range("C69").Value ActiveCell.Offset(0, 22).Value = wb1.Range("C68").Value ActiveCell.Offset(0, 23).Value = wb1.Range("C76").Value ActiveCell.Offset(0, 24).Value = wb1.Range("C77").Value Exit Sub

  • ExcelのVBAについて質問です。Excelは2003です。

    ExcelのVBAについて質問です。Excelは2003です。 コマンドボタン1で下記のプログラムを実行するようにしています。 Sub Macro1() ' ' Macro1 Macro ' ' Dim iRows As Integer Dim sRows As String Dim i As Integer For i = 1 To 100 Application.Wait Now + TimeValue("00:00:05") ' 最終行の調査: iRows = Worksheets("Sheet1").UsedRange.Rows.Count ' 最終行をシート3にコピー Worksheets("Sheet1").Rows(iRows).Copy Destination:=Worksheets("Sheet4").Range("1:1") ' CH1 の最新データをシート3にコピー Worksheets("Sheet3").Range("B9").Value = Worksheets("Sheet1").Cells(iRows, 3).Value ' CH2 の最新データをシート3にコピー Worksheets("Sheet3").Range("C9").Value = Worksheets("Sheet1").Cells(iRows, 4).Value Next i End Sub これをコマンドボタン2で途中でも強制的に終了するようにしたいのですがコマンドボタン2にはどのようなプログラムを入れればいいでしょうか?

  • EXCEL VBAがうまく動きません。

    指定された rangeの中から2番目に小さい値を検索し、そのセルの行数を求めようとしていますが、えらーが出ます。いくつか試してみましたがだめでした。 初歩的な質問で恐縮ですが、教えてください。 構文は以下のように書きました。 Private Sub test() Dim s As Double Dim r As Range Dim secondsmall As range Dim smallrow as integer r = Worksheets("sheet1").Range("a1:a4") s = WorksheetFunction.Small(r, 2) secondsmall = WorksheetFunction.Find(what:=s) smallrow = secondsmall.row MsgBox smallrow end sub 宜しくお願いします。

  • エクセルVBAについて

    http://okwave.jp/qa/q7236213.html 上記質問の発展形なのですが 同様のことを E列に日付 F列に売上 G列に結果 でやりたいのですが この時A列~C列のマクロも残したままでしたいのですが 下記のように同様のプロシージャーを下段に書けばできると思ったのですが うまくいきません。 Private Sub worksheet_change(ByVal Target As Excel.Range) If Target.Address <> "$A$1" Then Exit Sub If Target = "" Then Exit Sub Range("C10:C65536").ClearContents With Range(Cells(9 + Range("A1").Value, "C"), Cells(Range("A65536").End(xlUp).Row, "C")) .FormulaR1C1 = "=MAX(RC2:R[" & -Range("A1").Value + 1 & "]C2,FALSE)" .Value = .Value End With End Sub Private Sub worksheet_change(ByVal Target As Excel.Range) If Target.Address <> "$E$1" Then Exit Sub If Target = "" Then Exit Sub Range("G10:G65536").ClearContents With Range(Cells(9 + Range("E1").Value, "G"), Cells(Range("E65536").End(xlUp).Row, "G")) .FormulaR1C1 = "=MAX(RC6:R[" & -Range("A1").Value + 1 & "]C6,FALSE)" .Value = .Value End With End Sub どなたかお知恵を拝借できませんでしょうか?