こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

エクセルVBAプログラム質問 リストボックス応用

エクセルVBAプログラムについて質問です。
リストボックスから結果をリストボックスに表示させる
リストボックスを応用した内容です。

(1)今回追加したいのは、チェックボックスにチェックすることで、
期限が今月中に切れるもののみをリストボックスに表示させたいです。
(2)期限更新ボタンを押したら、3カ月プラスして延長させたいです。
期限更新したら、リストボックスの中身も更新したいです。

例(1):今日の日付 2018/9/23だとしたら、期限切れる(9月分すべて)を表示させたい。
例(2):期限(変更前)『2018/9/23』から期限(変更後)『2018/12/23』に変更

下記のプログラムで追加していきたいです。

Dim myData

Private Sub UserForm_Initialize()
Dim Dic, Keys, buf As String, i As Long

Me.ComboBox1.Style = fmStyleDropDownList
Me.ListBox1.ColumnCount = 4
Me.ListBox1.ListStyle = fmListStyleOption
Me.ListBox1.MultiSelect = fmMultiSelectMulti
Me.CommandButton1.Caption = "印刷"
Me.CommandButton1.Enabled = False

With Worksheets("DATA")
myData = .Range("A1:E" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With

Set Dic = CreateObject("Scripting.Dictionary")

On Error Resume Next
For i = 2 To UBound(myData, 1)
buf = myData(i, 1)
Dic.Add buf, buf
Next i

Keys = Dic.Keys
For i = 0 To Dic.Count - 1
Me.ComboBox1.AddItem Keys(i)
Next i

Set Dic = Nothing

End Sub

Private Sub ComboBox1_Change()
Dim i As Long, j As Integer

With Me.ListBox1
.Clear
For i = 2 To UBound(myData, 1)
If Me.ComboBox1.Value = myData(i, 1) Then
.AddItem ""
For j = 2 To 5
.List(.ListCount - 1, j - 2) = myData(i, j)
Next j
End If
Next i
End With

End Sub

Private Sub ListBox1_Change()
Dim i As Long, cnt As Long

With Me.ListBox1
For i = 0 To .ListCount - 1
If .Selected(i) Then
cnt = cnt + 1
End If
Next i
End With

Me.CommandButton1.Enabled = (1 <= cnt And cnt <= 2)

End Sub

Private Sub CommandButton1_Click()
Dim ws As Worksheet, i As Long, j As Integer, cnt As Byte

Set ws = Worksheets("印刷")
ws.PageSetup.PrintArea = "$I$2:$P$5"
ws.Range("J2:L5,N2:P5").ClearContents

With Me.ListBox1
For i = 0 To .ListCount - 1
If .Selected(i) Then
ws.Range("J2").Offset(0, cnt).Value = Me.ComboBox1.Value
For j = 0 To 2
ws.Range("J5").Offset(j * -1, cnt).Value = .List(i, j)
Next j
cnt = cnt + 2
End If
Next i
End With

Unload Me

ws.PrintPreview

End Sub

投稿日時 - 2018-09-24 19:42:44

QNo.9540733

困ってます

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(2)

ANo.2

>期限更新ボタンを押したら、3カ月プラスして延長させたいです。
期限更新ボタンを押し、その後、
期限が今月中に切れるもののみに戻したいときがあるかもしれないので
期限更新ボタンを押す都度、サイクリックに切り替わるようにしてみました。

大の月から小の月に変わるとき、たとえば、
本日が11月29日や30日の時、延長した場合の日付を求めるロジックが未詳です。

簡単な動作テストしかしていません。
よかったら使ってみてください。

'///☆の部分が追加修正箇所です。

Option Explicit

 Dim myData
 Dim MonthFlg As Boolean    '///☆
 

Private Sub UserForm_Initialize()
 Dim Dic, Keys, buf As String, i As Long

 MonthFlg = False        '///☆
 
 Me.ComboBox1.Style = fmStyleDropDownList
 Me.ListBox1.ColumnCount = 4
 Me.ListBox1.ListStyle = fmListStyleOption
 Me.ListBox1.MultiSelect = fmMultiSelectMulti
 Me.CommandButton1.Caption = "印刷"
 Me.CommandButton1.Enabled = False

 With Worksheets("DATA")
  myData = .Range("A1:E" & .Cells(.Rows.Count, 1).End(xlUp).Row)
 End With

 Set Dic = CreateObject("Scripting.Dictionary")

 On Error Resume Next
 For i = 2 To UBound(myData, 1)
  buf = myData(i, 1)
  Dic.Add buf, buf
 Next i

 Keys = Dic.Keys
 For i = 0 To Dic.Count - 1
  Me.ComboBox1.AddItem Keys(i)
 Next i

 Set Dic = Nothing

End Sub


'///☆----------------------------------------------------------------
Private Sub ComboBox1_Change()
 makeListBox Me.CheckBox1.Value
End Sub
Private Sub CheckBox1_Click()
 makeListBox Me.CheckBox1.Value
End Sub
Private Sub CommandButton2_Click() '月数変更ボタン
 MonthFlg = Not MonthFlg
 makeListBox Me.CheckBox1.Value
End Sub

Sub makeListBox(sw As Boolean)

 Dim i As Long, j As Integer
 Dim CheckDate As Date
 
 CheckDate = DateSerial(Year(Now), Month(Now), 1)  '当月の1日0時を算出
 If sw = True Then
  CheckDate = DateAdd("m", 1, CheckDate) '翌月の1日0時
 Else
  CheckDate = DateSerial(3000, 1, 1)   '大きく未来の1月1日0時
 End If
 
 If MonthFlg = True Then
  CheckDate = Int(Now)
  CheckDate = DateAdd("m", 3, CheckDate) + 1 '本日の3か月後の翌日0時
 End If
 
 'MsgBox Format(CheckDate, "YYYY/MM/DD hh:mm:ss")  'デバック用コード
 
 With Me.ListBox1
  .Clear
  For i = 2 To UBound(myData, 1)
   If myData(i, 5) < CheckDate Then       '日付範囲チェック
    If Me.ComboBox1.Value = myData(i, 1) Then
     .AddItem ""
     For j = 2 To 5
      .List(.ListCount - 1, j - 2) = myData(i, j)
     Next j
    End If
   End If
  Next i
 End With

End Sub
'///☆----------------------------------------------------------------


Private Sub ListBox1_Change()
 Dim i As Long, cnt As Long

 With Me.ListBox1
  For i = 0 To .ListCount - 1
   If .Selected(i) Then
    cnt = cnt + 1
   End If
  Next i
 End With

 Me.CommandButton1.Enabled = (1 <= cnt And cnt <= 2)

End Sub

Private Sub CommandButton1_Click()
 Dim ws As Worksheet, i As Long, j As Integer, cnt As Byte

 Set ws = Worksheets("印刷")
 ws.PageSetup.PrintArea = "$I$2:$P$5"
 ws.Range("J2:L5,N2:P5").ClearContents

 With Me.ListBox1
  For i = 0 To .ListCount - 1
   If .Selected(i) Then
    ws.Range("J2").Offset(0, cnt).Value = Me.ComboBox1.Value
    For j = 0 To 2
     ws.Range("J5").Offset(j * -1, cnt).Value = .List(i, j)
    Next j
    cnt = cnt + 2
   End If
  Next i
 End With

 Unload Me

 ws.PrintPreview

End Sub

投稿日時 - 2018-09-25 16:06:30

ANo.1

Initializeイベントは提案です。利用はご自由に
Private Sub UserForm_Initialize()
Dim Dic As Object, i As Long
Me.ComboBox1.Style = fmStyleDropDownList
Me.ListBox1.ColumnCount = 4
Me.ListBox1.ListStyle = fmListStyleOption
Me.ListBox1.MultiSelect = fmMultiSelectMulti
Me.CommandButton1.Caption = "印刷"
Me.CommandButton1.Enabled = False

With Worksheets("DATA")
myData = .Range("A1:E" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
Set Dic = CreateObject("Scripting.Dictionary")
On Error Resume Next
For i = 2 To UBound(myData, 1)
Dic(myData(i, 1)) = Empty
Next
Me.ComboBox1.List = Application.Transpose(Dic.Keys)
Set Dic = Nothing
End Sub
>(1)今回追加したいのは、チェックボックスにチェックすることで、
>期限が今月中に切れるもののみをリストボックスに表示させたいです。
Private Sub CheckBox1_Click()
Dim i As Long, j As Long
If Me.CheckBox1.Value = False Then Exit Sub
With Me.ListBox1
.Clear
For i = 2 To UBound(myData, 1)
If Month(Now) = Month(myData(i, 5)) Then
.AddItem ""
For j = 2 To 5
.List(.ListCount - 1, j - 2) = myData(i, j)
Next j
End If
Next i
End With
End Sub
>(2)期限更新ボタンを押したら、3カ月プラスして延長させたいです。
>期限更新したら、リストボックスの中身も更新したいです。
Private Sub CommandButton2_Click()
Dim i As Long, j As Long
'If Me.CheckBox1.Value = False Then Exit Sub
Me.ListBox1.Clear
With Worksheets("DATA")
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If DateSerial(Year(.Cells(i, "E").Value), Month(.Cells(i, "E").Value), 1) = _
DateSerial(Year(Now), Month(Now), 1) Then
.Cells(i, "E").Value = DateAdd("m", 3, .Cells(i, "E").Value)
Me.ListBox1.AddItem ""
For j = 2 To 5
Me.ListBox1.List(Me.ListBox1.ListCount - 1, j - 2) = .Cells(i, j).Value
Next j
End If
Next
myData = .Range("A1:E" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
End Sub

投稿日時 - 2018-09-25 14:33:13

あなたにオススメの質問