| |
如何、回答したら善いか善く解らないので
試しに作って見ました
ただ、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
|
|
Hirofumi
- 04/10/24(日) 21:25 -
