Excel VBA質問箱 IV

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

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


62163 / 76738 ←次へ | 前へ→

【19183】Re:シートの値をtextboxへ取り込みたいので...
回答  Hirofumi  - 04/10/24(日) 21:25 -

引用なし
パスワード
   如何、回答したら善いか善く解らないので
試しに作って見ました
ただ、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

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 お礼

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