|
如何、回答したら善いか善く解らないので
試しに作って見ました
ただ、TextBoxとスピンボタンの組み合わせは、ComboBoxにして有ります
シートのカレンダーは、以下のコードで作成されるカレンダーを使う物と想定しています
尚、「Sub CreateCalendar」のrngListTopで設定されるセル位置と
UserFormの「Sub UserForm_Initialize」のrngListTopで設定されるセル位置を同じにして下さい
rngListTopで設定されるセル位置を替えれば、表の位置は自由に変更できます
Option Explicit
Public Sub CreateCalendar()
Dim i As Long
Dim j As Long
Dim rngListTop As Range
Dim vntYear As Variant
Dim lngMonth As Long
Dim lngDay As Long
Dim vntCale As Variant
Dim lngRow As Long
Dim lngTime(1 To 6, 1 To 1) As Long
Dim wkstmp As Worksheet
vntYear = Application.InputBox(Prompt:="作成するカレンダの年を入力して下さい", _
Title:="カレンダ作成", Default:=Year(Date) + 1, _
Type:=2)
If VarType(vntYear) = vbBoolean Then
Exit Sub
End If
'カレンダーの4月1日のセル位置
Set rngListTop = ActiveSheet.Cells(1, "B")
For i = 1 To 6
lngTime(i, 1) = i
Next i
lngRow = 0
For i = 0 To 11
lngMonth = (i + 4)
lngDay = Day(DateSerial(vntYear, lngMonth + 1, 0))
ReDim vntCale(1 To 2, 1 To lngDay)
For j = 1 To lngDay
vntCale(1, j) = DateSerial(vntYear, lngMonth, j)
vntCale(2, j) = Choose((vntCale(1, j) - 1) Mod 7 + 1, "日", _
" 月", "火", "水", "木", "金", "土")
Next j
With rngListTop.Offset(lngRow)
.Resize(2, lngDay).Value = vntCale
.Resize(, lngDay).NumberFormat = "m/d"
.Offset(2, -1).Resize(6).Value = lngTime
For j = 0 To lngDay - 1
Select Case (.Offset(, j).Value - 1) Mod 7 + 1
Case 1
.Offset(1, j).Interior.ColorIndex = 38
Case 7
.Offset(1, j).Interior.ColorIndex = 36
End Select
Next j
End With
lngRow = lngRow + 9
Next i
Set rngListTop = Nothing
Beep
MsgBox "処理が完了しました"
End Sub
UserFormのコントロール
ComboBox1 :月表示用
ComboBox2 :週表示用
Label2〜6 :日付表示用
TextBox21〜26 :月曜1〜6時限表示
TextBox31〜36 :火曜1〜6時限表示
TextBox41〜46 :水曜1〜6時限表示
TextBox51〜56 :木曜1〜6時限表示
TextBox61〜66 :金曜1〜6時限表示
CommandButton1 :時間割表示
CommandButton2 :更新
CommandButton1 :閉じる
で作って有ります
以下をUserFormのコードモジュールに記述して下さい
Option Explicit
Private rngListTop As Range
Private dtmCurrent As Date
Private Sub ComboBox1_Change()
Dim i As Long
Dim lngWeek As Long
lngWeek = GetWeekNumb(DateValue(ComboBox1.Value & "1日"))
With ComboBox2
.Clear
For i = 1 To lngWeek
.AddItem i & "週"
Next i
.ListIndex = 0
End With
End Sub
Private Sub CommandButton1_Click()
If ComboBox1.ListIndex <> -1 _
And ComboBox2.ListIndex <> -1 Then
dtmCurrent = GetWeekDay(CDate(ComboBox1.Value & "1日"), _
Val(ComboBox2.Value))
DataRead
End If
End Sub
Private Sub CommandButton2_Click()
DataPut
End Sub
Private Sub CommandButton3_Click()
Unload Me
End Sub
Private Sub UserForm_Initialize()
Dim i As Long
Dim lngYear As Long
'カレンダーの4月1日のセル位置
Set rngListTop = ActiveSheet.Cells(1, "B")
With rngListTop
If IsDate(.Value) Then
lngYear = Year(.Value)
Else
lngYear = Year(Date)
End If
End With
With ComboBox1
.Style = fmStyleDropDownList
For i = 0 To 11
.AddItem (lngYear + (i + 3) \ 12) & "年" _
& (((i + 3) Mod 12) + 1) & "月"
Next i
End With
With ComboBox2
.Style = fmStyleDropDownList
End With
End Sub
Private Sub UserForm_Terminate()
Set rngListTop = Nothing
End Sub
Private Function GetWeekNumb(dtmMonth As Date) As Long
Dim i As Long
Dim dtmTop As Date
Dim dtmEnd As Date
dtmTop = dtmMonth - ((dtmMonth - 1) Mod 7)
dtmEnd = DateAdd("m", 1, dtmMonth)
GetWeekNumb = -Int(-(dtmEnd - dtmTop) / 7)
End Function
Private Function GetWeekDay(dtmMonth As Date, lngWeek As Long) As Date
Dim i As Long
Dim dtmTop As Date
Dim dtmEnd As Date
If lngWeek = 1 Then
GetWeekDay = dtmMonth
Else
dtmTop = dtmMonth - ((dtmMonth - 1) Mod 7)
GetWeekDay = DateAdd("ww", lngWeek - 1, dtmTop) + 1
End If
End Function
Private Sub DataRead()
Dim i As Long
Dim j As Long
Dim lngRow As Long
Dim lngCol As Long
Dim dtmTop As Date
dtmTop = dtmCurrent - ((dtmCurrent - 1) Mod 7)
lngCol = Day(dtmCurrent) - 1
lngRow = ((Month(dtmCurrent) + 8) Mod 12) * 9 + 2
rngListTop.Offset(lngRow - 2, lngCol).Select
For i = 2 To 6
If Month(dtmTop + i - 1) = Month(dtmCurrent) Then
Controls("Label" & i).Caption = Format(dtmTop + i - 1, "m/d(aaa)")
For j = 1 To 6
Controls("TextBox" & i & j).Text _
= rngListTop.Offset(lngRow + j - 1, lngCol).Value
Next j
lngCol = lngCol + 1
Else
Controls("Label" & i).Caption = ""
For j = 1 To 6
Controls("TextBox" & i & j).Text = ""
Next j
End If
Next i
End Sub
Public Sub DataPut()
Dim i As Long
Dim j As Long
Dim lngRow As Long
Dim lngCol As Long
Dim dtmTop As Date
dtmTop = dtmCurrent - ((dtmCurrent - 1) Mod 7)
lngCol = Day(dtmCurrent) - 1
lngRow = ((Month(dtmCurrent) + 8) Mod 12) * 9 + 2
rngListTop.Offset(lngRow - 2, lngCol).Select
For i = 2 To 6
If Month(dtmTop + i - 1) = Month(dtmCurrent) Then
For j = 1 To 6
rngListTop.Offset(lngRow + j - 1, lngCol).Value _
= Controls("TextBox" & i & j).Text
Next j
lngCol = lngCol + 1
End If
Next i
End Sub
|
|