Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


62033 / 76732 ←次へ | 前へ→

【19309】Re:ここまでは考えたのですが・・・.
回答  Hirofumi  - 04/10/27(水) 22:05 -

引用なし
パスワード
   一応、コメントを付けて見ましたけれど
何か言い回しが下手で上手く説明が出来ていないかも?

前回のコードを少し整理、変更してあります
カレンダの有るシートを見ているのは、
基準位置の日付(シリアル値)だけです
日付の位置は、基準セル位置と、月が書かれている行のピッチから
計算して出しています
詰まり、シートには、基準セル位置に、シリアル値が有れば後は何も無くても動きます

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

'全てのモジュールら参照出来る変数を宣言
'月が書かれている行のピッチ
'例、4月が1行目で、5月が10行目なら9行ピッチ
Public lngMonthPitch As Long

'UserForm内全てから参照出来る変数を宣言
'データ出力の基準セル位置(4月1日のセル位置)
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は、月が書かれている行のピッチ
  '例、4月が1行目で、5月が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
0 hits

【19171】シートの値をtextboxへ取り込みたいので... ponpon 04/10/24(日) 15:33 質問
【19176】Re:シートの値をtextboxへ取り込みたいので... こもれび 04/10/24(日) 17:40 回答
【19179】Re:シートの値をtextboxへ取り込みたいの... ponpon 04/10/24(日) 18:21 質問
【19180】Re:シートの値をtextboxへ取り込みたいの... kobasan 04/10/24(日) 20:38 発言
【19181】Re:シートの値をtextboxへ取り込みたいの... かみちゃん 04/10/24(日) 20:58 発言
【19184】Re:シートの値をtextboxへ取り込みたいの... ponpon 04/10/24(日) 21:31 発言
【19182】Re:シートの値をtextboxへ取り込みたいの... ponpon 04/10/24(日) 21:18 質問
【19218】Re:シートの値をtextboxへ取り込みたいの... kobasan 04/10/25(月) 20:40 発言
【19220】Re:シートの値をtextboxへ取り込みたいの... ponpon 04/10/25(月) 21:14 お礼
【19183】Re:シートの値をtextboxへ取り込みたいので... Hirofumi 04/10/24(日) 21:25 回答
【19186】Re:シートの値をtextboxへ取り込みたいので... ponpon 04/10/24(日) 21:49 発言
【19187】不都合が有るみたいなので修正します Hirofumi 04/10/24(日) 21:51 回答
【19191】Re:不都合が有るみたいなので修正します ponpon 04/10/24(日) 22:42 発言
【19221】Re:不都合が有るみたいなので修正します Hirofumi 04/10/25(月) 22:13 発言
【19261】よろしくお願いします。 ponpon 04/10/26(火) 18:25 発言
【19305】ここまでは考えたのですが・・・. ponpon 04/10/27(水) 20:58 質問
【19307】Re:ここまでは考えたのですが・・・. Hirofumi 04/10/27(水) 21:19 発言
【19308】Re:ここまでは考えたのですが・・・. ponpon 04/10/27(水) 21:38 発言
【19309】Re:ここまでは考えたのですが・・・. Hirofumi 04/10/27(水) 22:05 回答
【19310】Re:ここまでは考えたのですが・・・. ponpon 04/10/27(水) 23:25 お礼
【19348】Re:ここまでは考えたのですが・・・. Hirofumi 04/10/28(木) 20:15 回答
【19349】Re:ここまでは考えたのですが・・・. ponpon 04/10/28(木) 21:15 お礼

62033 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free