| |
一応、コメントを付けて見ましたけれど
何か言い回しが下手で上手く説明が出来ていないかも？
前回のコードを少し整理、変更してあります
カレンダの有るシートを見ているのは、
基準位置の日付（シリアル値）だけです
日付の位置は、基準セル位置と、月が書かれている行のピッチから
計算して出しています
詰まり、シートには、基準セル位置に、シリアル値が有れば後は何も無くても動きます
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の呼び出し時に、月の書かれている行ピッチを指定できる様に変更して有ります
例
Public Sub UserFormShow()
With UserForm1
'行ピッチの指定（此れを指定しない場合、9行ピッチ）
.lngMonthPitch = 11
.Show
End With
End Sub
Option Explicit
'全てのモジュールら参照出来る変数を宣言
'月が書かれている行のピッチ
'例、４月が1行目で、５月が10行目なら9行ピッチ
Public lngMonthPitch As Long
'UserForm内全てから参照出来る変数を宣言
'データ出力の基準セル位置（４月１日のセル位置）
Private rngListTop As Range
'週の先頭の日付
Private dtmCurrent As Date
Private Sub ComboBox1_Change()
'月が変更された場合
Dim i As Long
Dim lngWeek As Long
'ComboBox1で選択された月が何週有るかを計算
lngWeek = GetWeekNumb(DateValue(ComboBox1.Value & "1日"))
'ComboBox2に計算された週をセット
With ComboBox2
.Clear
For i = 1 To lngWeek
.AddItem i & "週"
Next i
.ListIndex = 0
End With
'選択されている月、週からシートのデータを
'TextBoxに読み込む
WeekChange
End Sub
Private Sub ComboBox2_Change()
'週が変更された場合
'選択されている月、週からシートのデータを
'TextBoxに読み込む
WeekChange
End Sub
Private Sub CommandButton2_Click()
'更新ボタンが押された場合
'TextBoxのデータをシートに出力
DataPut
End Sub
Private Sub CommandButton3_Click()
Unload Me
End Sub
Private Sub UserForm_Initialize()
Dim i As Long
Dim lngYear As Long
'デフォルトとして9行ピッチを設定
lngMonthPitch = 9
'カレンダーの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
'ComboBox1の設定
With ComboBox1
'ドロップダウンリストとする
.Style = fmStyleDropDownList
'月を設定（年を付加、4月から翌年3月まで）
'lngYear + (i + 3) \ 12は、iが9を超えると1が加算される
'詰まり、1月以降は翌年に成る
'((i + 3) Mod 12) + 1は、iが0〜11に変かするに伴い
'4〜3の値が計算される
For i = 0 To 11
.AddItem (lngYear + (i + 3) \ 12) & "年" _
& (((i + 3) Mod 12) + 1) & "月"
Next i
End With
'ComboBox2の設定
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 - (WeekDay(dtmMonth) - 1)
'翌月の月初の日付を計算
dtmEnd = DateAdd("m", 1, dtmMonth)
'戻り値をして、先頭週の日曜から月末までの日数を
'7日で割って切り上げる（一月が何週に成るか計算）
GetWeekNumb = -Int(-(dtmEnd - dtmTop) / 7)
End Function
Private Function GetWeekDay(dtmMonth As Date, _
lngWeek As Long) As Date
'指定月（月の1日を指定）の指定週の先頭の日付を返す関数
Dim i As Long
Dim dtmTop As Date
Dim dtmEnd As Date
'第1週の場合
If lngWeek = 1 Then
'月初の日付を返す
GetWeekDay = dtmMonth
Else
'月初の有る週の日曜の日付を計算
dtmTop = dtmMonth - (WeekDay(dtmMonth) - 1)
'先頭日付に指定週分の日数+1を加算して週の先頭日付を返す
GetWeekDay = DateAdd("ww", lngWeek - 1, dtmTop) + 1
End If
End Function
Private Sub DataRead()
'シートのデータをTextBoxに読み込む
Dim i As Long
Dim j As Long
Dim lngRow As Long
Dim lngCol As Long
Dim dtmTop As Date
'週の先頭日付からシートの行列位置を
'基準セルからのOffset値として計算
LocateCalc dtmTop, lngRow, lngCol
'視認性の為セルをSelect（無くてもOk）
rngListTop.Offset(lngRow - 2, lngCol).Select
'TextBoxに読み込み
For i = 2 To 6
'もし、実際の週先頭の日（日曜日）から(i-1)日目の月が、
'週先頭の月と同じなら（月初の様に週先頭と第一週の先頭日が違う時の処理）
'dtmTopは、常に日曜日を指し、10月の第1週は9/26日
'dtmCurrentは、例えば、月初の場合10/1が金曜で有っても週先頭としている
If Month(dtmTop + i - 1) = Month(dtmCurrent) Then
'ラベルに日付を書き込む
Controls("Label" & i).Caption = Format(dtmTop + i - 1, "m/d(aaa)")
'1〜6時限のセルを読み出す
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 = ""
'TextBoxをクリア
For j = 1 To 6
Controls("TextBox" & i & j).Text = ""
Next j
End If
Next i
End Sub
Public Sub DataPut()
'TextBoxの値をセルに書き出し
Dim i As Long
Dim j As Long
Dim lngRow As Long
Dim lngCol As Long
Dim dtmTop As Date
LocateCalc dtmTop, lngRow, lngCol
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
Private Sub LocateCalc(dtmTop As Date, _
lngRow As Long, _
lngCol As Long)
'セル位置（Offset値）の計算
'dtmCurrentの日付が含まれる週の先頭日付
dtmTop = dtmCurrent - (WeekDay(dtmCurrent) - 1)
'シートの列位置
lngCol = Day(dtmCurrent) - 1
'シートの行位置
'(Month(dtmCurrent) + 8) Mod 12は、月の順番（順位？）を計算
'4月は0番目、3月は11番目
'lngMonthPitchは、月が書かれている行のピッチ
'例、４月が1行目で、５月が10行目なら9行ピッチ
lngRow = ((Month(dtmCurrent) + 8) Mod 12) _
* lngMonthPitch + 2
End Sub
Private Sub WeekChange()
'各ComboBoxが変化した特の処理
If ComboBox1.ListIndex <> -1 _
And ComboBox2.ListIndex <> -1 Then
dtmCurrent = GetWeekDay(CDate(ComboBox1.Value & "1日"), _
Val(ComboBox2.Value))
DataRead
End If
End Sub
|
|
Hirofumi
- 04/10/27(水) 22:05 -
