[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『カレンダーの作成』（7個）
教えてください。
A1に×年○月を入力すると、B2に○月1日・C2に○月2日・D3に○月3日・・・末日まで。
と表示させるカレンダーを作成したいのですがよろしくお願いします。
A1に
"2008/1/1"
と入力("2008/1"と入力しても自動的に"22008/1/1"となると思います。)
B2=IF(MONTH($A$1+COLUMN()-2)<>MONTH($A$1),"",$A$1+COLUMN()-2)
B2をC2～AF2にコピー
A1の日付の月と、A1の日付に列番号を加算して算出した日付の月とを比較し、 月が違ったら表示しない、という方法をとっています。 (MARBIN)
なお、 "2008/1/1" は表示形式で表示方法を変えられます。 ユーザー定義書式を使います。
一例です。 "yyyy年m月"→"2008年1月" "yyyy年mm月"→"2008年01月" "yy年mm月"→"08年01月" "gggee年m月"→"平成20年1月" "[DBNum3]ggge年m月"→"平成２０年１月" (MARBIN)
なお、A1に文字列で"2008年1月"と入力されている場合は、 B2=DATEVALUE(A1&COLUMN()-1&"日") で日付データに変換できます。 (MARBIN)
なお（その３ 上の[全文検索]の[もっとも多く検索されたキーワード]にもカレンダーがありますよ＾＾ （dack）
今月を例にとるならA1セルに12/1と入力することをお薦めします。エクセルは2007/12/1と認識します。 あとは、MARBINさんがご提示のユーザー定義で表示形式は選択すればよろしいと思います。
B2=A1 C2=B2+1 としてAF2(31日)までフィルコピー
AC2からAF2までドラッグ選択しておいて（28～31日分） 条件付き書式 数式が =MONTH($A$1)<>MONTH(AC2) 書式 フォント 白
小の月の場合、AF2には翌月1日が入りますがフォントを白色にして見えなくする手法です。(gon-2)
こんなスーパーカレンダーはどうでっか？
そのシートのシートモジュールにコピペします。
入力は３でも３月でも3でも平成１９年３月でもH19.3でもＨ１９．３でも２００７／３
でも2007/3でもＯＫですワ。
しかも土、日にはご丁寧に色付けまでする至れり尽くせりのカレンダーでっせぇ。
（弥太郎）
'--------------------------
Option Base 1
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer, n As Integer, data, ary, x()
With Target
If .Count > 1 Then Exit Sub
If .Address(0, 0) <> "A1" Then Exit Sub
.NumberFormatLocal = "G/標準"
If .Value = "" Then Cells(1, 2).Resize(2, Columns.Count - 1).Clear: Exit Sub
If IsNumeric(.Value) And Len(.Value) = 5 Then .NumberFormatLocal = "yyyy/m"
data = StrConv(.Value, vbNarrow)
data = IIf(IsNumeric(data), data & "月", data)
data = Replace(Replace(Replace(data, "H", "平成"), "S", "昭和"), "T", "大正")
End With
On Error Resume Next
data = Split(data, ".")(0) & "年" & Split(data, ".")(1) & "月"
data = Format(data, "yyyy/m")
If Not IsDate(data) Then
data = Format(Year(Now) & "/" & Val(data), "yyyy/m")
End If
ary = Array(31, IIf(Year(data) Mod 4 = 0, 29, 28), 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
For i = 1 To 12
If Month(data) = i Then Exit For
Next i
Application.EnableEvents = False
Cells(1, 2).Resize(2, Columns.Count - 1).Clear
For n = 1 To ary(i)
ReDim Preserve x(1 To 1, 1 To n)
x(1, n) = data & "/" & n
Next n
Cells(1, 2).Resize(, UBound(x, 2)) = x
Cells(1, 2).Resize(, UBound(x, 2)).NumberFormatLocal = "m月d日"
For n = 2 To UBound(x, 2)
Cells(1, n).Font.ColorIndex = IIf(Weekday(Cells(1, n)) = 7, 5, _
IIf(Weekday(Cells(1, n)) = 1, 3, xlAutomatic))
Next n
Application.EnableEvents = True
End Sub
横槍マクロです・・・。 弥太郎さんのマクロに↓を追加してみてください。
'標準モジュール Sub haiti() With ActiveSheet.Cells(2, 1) .Value = "前" .Font.Color = vbBlue End With With ActiveSheet.Cells(3, 1) .Value = "後" .Font.Color = vbRed End With End Sub
'シートモジュールに追加
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Range("A1").Value = "" Then Exit Sub
If Intersect(Target, Range("A2:A3")) Is Nothing Then Exit Sub
Cancel = True
With Range("A1")
Select Case Target.Address(0, 0)
Case "A2"
.Value = DateAdd("m", -1, .Value)
Case "A3"
.Value = DateAdd("m", 1, .Value)
End Select
End With
End Sub
先ず、"haiti"を実行してください。 A1に入力した日付を"前"、"後"のセルのダブルクックで一ヶ月単位で前後させることが出来ます。 A1に何も入力されていなければ"前"、"後"のセルをダブルクックしても何もおきません。
(MARBIN)
んじゃこっちはMARBINはんのを真似てスピンボタンバージョンといきまひょか。＾＾
そのシートにコントロールツールボックスからスピンボタンを配置します。
入力は３でも3でも３月でも平成１９年３月でもＨ１９．３でも２００７／３でも
ＯＫです。
ただ、年を入力しなければ当該年度しか表示しまへん。
また大正以前のカレンダーは作成でけまへん。
（弥太郎）
'------------------------
Option Base 1
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer, n As Integer, data, ary, x()
With Target
If .Count > 1 Then Exit Sub
If .Address(0, 0) <> "A1" Then Exit Sub
Application.ScreenUpdating = False
.NumberFormatLocal = "G/標準"
If .Value = "" Then Cells(1, 2).Resize(2, 31).Clear: Exit Sub
Application.EnableEvents = False
.Value = StrConv(.Value, vbNarrow)
If IsNumeric(.Value) And Len(.Value) = 5 Then .NumberFormatLocal = "yyyy/m"
data = .Value
data = IIf(IsNumeric(data), data & "月", data)
data = Replace(Replace(Replace(data, "H", "平成"), "S", "昭和"), "T", "大正")
data = Replace(Replace(Replace(data, "(", ""), ")", ""), ".", "年")
End With
On Error Resume Next
With CreateObject("vbscript.regexp")
data = Format(data, "yyyy/m")
If Not IsDate(data) Then
.Pattern = "^(\D+)(\d+)(\D+)(\d+)(\D+)*"
If .test(data) And Not data Like "*/*" Then
data = .Replace(data, "$1") & .Replace(data, "$2") & .Replace(data, "$3") & _
.Replace(data, "$4") & "月"
data = Format(data, "yyyy/m")
Else
.Pattern = "(\d+)(\D+)*"
If .test(data) And Not data Like "*/*" Then
data = Format(Year(Now) & "/" & .Replace(data, "$1"), "yyyy/m")
Else
.Pattern = "(\d{4}\/\d+)(\D+)*"
If .test(data) Then
data = .Replace(data, "$1")
Else
data = Format(Year(Now) & "/" & Val(data), "yyyy/m")
End If
End If
End If
End If
End With
ary = Array(31, IIf(Year(data) Mod 4 = 0, 29, 28), 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
For i = 1 To 12
If Month(data) = i Then Exit For
Next i
Cells(1, 2).Resize(2, 31).Clear
For n = 1 To ary(i)
ReDim Preserve x(1 To 2, 1 To n)
x(1, n) = data & "/" & n
x(2, n) = Format(data & "/" & n, "aaa")
Cells(2, n + 1).Font.ColorIndex = IIf(Weekday(x(1, n)) = 7, 5, _
IIf(Weekday(x(1, n)) = 1, 3, xlAutomatic))
Next n
Cells(1, 2).Resize(, UBound(x, 2)).NumberFormatLocal = "m月d日"
Cells(1, 2).Resize(2, UBound(x, 2)) = x
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Private Sub SpinButton1_Change()
Dim flag As Boolean, i As Integer, ary, d, data
SpinButton1.Max = 1
SpinButton1.Min = -1
If SpinButton1.Value = 0 Then Exit Sub
If Range("A1").Value = "" Then SpinButton1.Value = 0: Exit Sub
With CreateObject("vbscript.regexp")
If Not Range("a1") Like "*/*" Then
.Pattern = "^(\()*(\d+)(\D+)*"
If .test(Range("a1").Text) Then
data = .Replace(Range("a1"), "$2") + SpinButton1.Value
data = IIf(data = 0, 12, IIf(data = 13, 1, data))
Range("a1") = .Replace(Range("a1"), "$1") & data & .Replace(Range("a1"), "$3")
SpinButton1.Value = 0
Exit Sub
Else
.Pattern = "^(\()*(\D+)(\d+)(\D+)(\d+)(\D+)*"
If .test(Range("a1")) Then
ReDim d(1 To 5)
For i = 1 To 5
d(i) = .Replace(Range("a1"), "$" & i + 1)
Next i
flag = True
End If
End If
ElseIf Not IsDate(Range("a1")) Then
.Pattern = "^(\()*(\d{4}/\d+)(\D+)*"
If .test(Range("a1")) Then
data = .Replace(Range("a1"), "$2") & "/" & 1
Range("a1") = .Replace(Range("a1"), "$1") & Format(DateAdd("m", _
SpinButton1.Value, data), "yyyy/m") & .Replace(Range("a1"), "$3")
SpinButton1.Value = 0
Exit Sub
End If
End If
ary = Array("平成", "昭和", "大正", "H", "S", "T")
If flag Then
Select Case SpinButton1.Value
Case -1
If d(1) = "大正" Or d(1) = "T" Then
If d(2) = 1 And d(4) = 1 Then MsgBox "それ以下はあきまへん", _
vbExclamation: SpinButton1.Value = 0: Exit Sub
d(2) = IIf(d(4) = 1, d(2) - 1, d(2))
Else
d(1) = IIf(d(2) = 1 And d(4) = 1, ary(Application.Match(d(1), ary, 0) + 1), d(1))
d(2) = IIf(d(2) = 1 And d(4) = 1, IIf(d(1) = "昭和" Or d(1) = "S", 63, 14), _
IIf(d(4) = 1, d(2) - 1, d(2)))
End If
Range("a1") = .Replace(Range("a1"), "$1") & d(1) & d(2) & d(3) & IIf(d(4) = 1, _
12, d(4) - 1) & d(5)
Case 1
If d(1) = "平成" Or d(1) = "H" Then
d(2) = IIf(d(4) = 12, d(2) + 1, d(2))
Else
d(1) = IIf((d(2) = 14 And d(4) = 12 And (d(1) = "大正" Or d(1) = "T")) Or (d(2) = 63 _
And d(4) = 12 And (d(1) = "昭和" Or d(1) = "S")), ary(Application.Match(d(1), _
ary, 0) - IIf(d(1) = "平成" Or d(1) = "H", 0, 1)), d(1))
d(2) = IIf((d(2) = 14 And d(4) = 12 And (d(1) = "昭和" Or d(1) = "S")) Or _
(d(2) = 63 And d(4) = 12 And d(1) = "平成" Or d(1) = "H"), _
1, IIf(d(4) = 12, d(2) + 1, d(2)))
End If
Range("a1") = .Replace(Range("a1"), "$1") & d(1) & d(2) & d(3) & IIf(d(4) _
= 12, 1, d(4) + 1) & d(5)
End Select
Else
Range("a1") = DateAdd("m", SpinButton1.Value, Range("a1"))
End If
End With
SpinButton1.Value = 0
End Sub
カレンダーの日付を関数で参照するとえらい間違いが起こる重大ミスを発見。（汗 過去ログ頼りに訪れる御方の為にも訂正しておく必要がありますんで、上記コード 差し替えました。償いとして（平成19年3月分）等とカッコにも対応するよう機能を アップしときました、やれやれ。 （弥太郎）
重大ミスとは？？？
GGG
差し替える前のマクロはこうなっとりましたんですワ。 A1に平成１６年３月度と入力しても B1の日付は2007/3/1と表示しとりました。 ○月○日の表示自体はその月の日数で表示されますから、カレンダー単体で使用する ばやいは何ら問題はないんですけど、その表示された日付を利用して、例えば どっかのセルに=DATEDIF(B1,NOW(),"m") と入力すると求める数値とは全く違う結果が出る事になります。 起算日が2004/3/1で有るべき筈が2007/3/1になっとるのが原因なんですワ。
上のコードをコピペして今年以外の年代をA1に記入すれば上の式は有効になりますが B1に３月１日と入力しますと、どうでっか？結果はちがいまっしゃろ？ こんな説明でご理解頂けましたかしら。 （弥太郎）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.