演習23 のユーザーフォーム コード
----- [ThisWorkbook] -----
Private Sub Workbook_Open()
UserForm1.Show False
End Sub
------ [UserForm1] -------
Dim Lr, Lc As Integer
Sub CommandButton1_Click()
'集計計算 (行列の挿入削除可能)
Dim Pt() As String
If Me.Tag = "1" Or Me.Tag = "2" Then '集計計算後または
Beep 'フィルタ設定の時
Exit Sub 'は再計算しない
End If
Me.Tag = "1" 'フラッグ
Lr = Range("A1").End(xlDown).Row '最終行
Lc = Range("A1").End(xlToRight).Column '最終列
ReDim Pt(Lr) '配列再確保
Cells(Lr + 2, 2).Value = "集計数"
For i = 1 To Lc - 2 '二列分を引算
Cells(Lr + 2, i + 2).FormulaR1C1 = _
"=SubTotal(2, R2C:R[-2]C)" '縦カウント
Next i
'選択型加工
Cells(1, Lc + 2).Value = "選択型"
For i = 1 To Lr - 1 '行列の変更可能
For j = 1 To Lc - 2
Pt(i + 1) = Pt(i + 1) & Str(Cells(i + 1, j + 2).Value)
Cells(i + 1, Lc + 2).Value = Val(Pt(i + 1))
Next j
Next i
Cells(Lr + 2, Lc + 2).Value = _
"=SubTotal(2, R2C:R[-2]C)"
Cells(1, 1).Select
End Sub
Sub CommandButton2_Click()
'集計消去
If Me.Tag <> "1" Then '集計計算後のみ
Beep '消去可能
Exit Sub
End If
For i = 1 To Lc - 1
Cells(Lr + 2, i + 1).Value = ""
Next i
For i = 1 To Lr + 2
Cells(i, Lc + 2).Value = ""
Next i
Me.Tag = ""
End Sub
Sub CommandButton3_Click()
'フィルタ設定
If Me.Tag <> "1" Then '集計計算後のみ
Beep 'フィルタ可能
Exit Sub
End If
Range(Cells(1, 3), Cells(1, Lc)).Select
Selection.AutoFilter
Selection.AutoFilter Field:=1
Me.Tag = "2" 'フィルタ用フラッグ
End Sub
Sub CommandButton4_Click()
'フィルタ解除
If Me.Tag = "2" Then 'フィルタ設定後
Selection.AutoFilter 'のみ解除可能
Cells(1, 1).Select
Else
Beep
Exit Sub
End If
Me.Tag = "1" 'フラッグを戻す
End Sub
Sub CommandButton5_Click()
'選択型ソート
If Me.Tag <> "1" And Me.Tag <> "2" Then '集計計算後または
Beep 'フィルタの後のみ
Exit Sub 'ソート可能
End If
Application.ScreenUpdating = False '画面の抑止設定
Range(Cells(2, 1), Cells(Lr, Lc + 2)).Select
Selection.Sort _
Key1:=Cells(2, Lc + 2), _
Order1:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin
Cells(1, 1).Select
Application.ScreenUpdating = True '画面の抑止解除
End Sub
Sub CommandButton6_Click()
'番号順ソート
If Me.Tag <> "1" And Me.Tag <> "2" Then '上記制限時のみ
Beep 'ソート可能
Exit Sub
End If
Application.ScreenUpdating = False
Range(Cells(2, 1), Cells(Lr, Lc + 2)).Select
Selection.Sort _
Key1:=Cells(2, 1), _
Order1:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin
Cells(1, 1).Select
Application.ScreenUpdating = True
End Sub
Sub CommandButton7_Click()
'検索呼び出し
If Me.Tag = "2" Then
MsgBox "フィルタを解除せよ"
Exit Sub
Else
If Me.Tag <> "1" Then '集計計算後のみ検索可能
Beep
Exit Sub
End If
End If
UserForm1.Hide
UserForm2.Show False
Worksheets("Sheet2").Activate
End Sub
Sub CommandButton8_Click()
'全終了
Unload UserForm1
'Unload UserForm2
End Sub
Private Sub UserForm_Initialize()
ThisWorkbook.Worksheets("Sheet1").Activate
'ユーザーフォームの表示位置指定
Me.StartUpPosition = 0
If Me.StartUpPosition = 0 Then
'Me.Top = (Screen.Height - Me.Height) / 1.5
'Me.Left = (Screen.Width - Me.Width) / 2
Me.Top = 320
Me.Left = 265
End If
End Sub
------ [UserForm2] -------
Dim Lr, Lc As Integer
Private Sub CommandButton1_Click()
'検索終了
UserForm1.Show False
Unload UserForm2
Worksheets("Sheet1").Activate
End Sub
Private Sub ListBox1_Click()
Beep
End Sub
Private Sub ListBox2_Click()
TextBox2 = ""
If ListBox2.ListIndex <> -1 Then
TextBox1.Value = ListBox2.Value 'リストから選択
End If
End Sub
Private Sub UserForm_QueryClose(Cancel _
As Integer, CloseMode As Integer)
'[x]ボタン無効
If CloseMode <> vbFormCode Then
Beep
Cancel = 1
End If
End Sub
Private Sub UserForm_Initialize()
'ユーザーフォームの表示位置指定
Me.StartUpPosition = 0
If Me.StartUpPosition = 0 Then
Me.Top = 230
Me.Left = 200
End If
'リストボックスに選択型データ取得
Dim Ds As String
Dim Dt As String
'最終行列
With ThisWorkbook.Worksheets("Sheet1")
Lr = .Range("A1").End(xlDown).Row
Lc = .Range("A1").End(xlToRight).Column
End With
'選択型データ範囲
'Dt1 = Cells(2, Lc + 2).Address(RowAbsolute _
' :=False, ColumnAbsolute:=False)
'Dt2 = Cells(Lr, Lc + 2).Address(RowAbsolute _
' :=False, ColumnAbsolute:=False)
'行列の挿入削除が可能な選択型を取得
'リストボックス1
Ds = "A2:B" & Lr '選択元の番号と名前
ListBox1.ColumnHeads = True '1行目タイトル
ListBox1.ColumnWidths = "40;60"
ListBox1.ColumnCount = 2 '2列に分割
ListBox1.RowSource = Ds '転記
'Dt2 = Chr(Lc + 64 + 2) & "2:" & Chr(Lc + 64 + 2) & Lr
'Range(Cells(2, Lc + 2), Cells(Lr, Lc + 2)).Name = "Dt"
'ListBox2.RowSource = Dt2
'ListBox2.RowSource = "Dt"
'例. A = Chr(1 + 64) = Chr(65) A〜Z は Chr(65) から
' G = Chr(7 + 64) = Chr(71) Chr(90) に対応している
' I = Chr(7 + 64 + 2) = Chr(7 + 66) = Chr(73)
'リストボックス2
ListBox2.ColumnHeads = True
With ThisWorkbook.Worksheets("Sheet1") '選択型転記
Dt = .Range(Cells(2, Lc + 2), Cells(Lr, Lc + 2)).Name
ListBox2.RowSource = Dt
End With
End Sub
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False '画面の抑止設定
'Sheet2 の1行目タイトル表示
With ThisWorkbook
.Worksheets("Sheet1").Range("A1:" & _
Chr(Lc + 66) & CStr(1)).Copy Destination:= _
.Worksheets("Sheet2").Range("A1") '左上
End With
With ThisWorkbook
.Worksheets("Sheet1").Range("A1:" & _
Chr(Lc + 66) & CStr(1)).Copy Destination:= _
.Worksheets("Sheet2").Range(Chr(Lc + 70) & CStr(1)) '右上
End With
'With ThisWorkbook
' TextBox1.Value = .Worksheets("Sheet1"). _
' Range(Chr(Lc + 66) & CStr(1)). _
' Offset(ListBox2.ListIndex + 1).Value
'End With
If TextBox1.Value = "" And _
ListBox2.ListIndex = -1 Then
MsgBox "選択型をクリックするか手入力せよ", vbExclamation
Exit Sub
End If
If TextBox1.Value = "" And _
ListBox2.ListIndex <> -1 Then
TextBox1.Value = ListBox2.Value 'リストから選択
End If
With ThisWorkbook.Worksheets("Sheet2") '検索シート設定
.Range(Chr((Lc + 64 + 2 + 4 - 1) + _
(Lc + 2)) & "2").Value = TextBox1.Value '検索型を記入
End With '(U2)
'検索実行
'Sheet1(A列〜I列) を、Sheet2(M1〜U2) で検索
With ThisWorkbook '元シート設定
.Worksheets("Sheet1"). _
Columns("A:" & Chr(Lc + 66)).AdvancedFilter _
CriteriaRange:=.Worksheets("Sheet2") _
.Range(Chr(Lc + 66 + 4) & "1:" & _
Chr((Lc + 66 + 4 - 1) + (Lc + 2)) & "2"), _
Action:=xlFilterCopy, _
CopyToRange:=.Worksheets("Sheet2"). _
Columns("A:" & Chr(Lc + 66)), _
Unique:=False
End With
'Sheet2(I列) を集計
With ThisWorkbook.Worksheets("Sheet2") '集計結果の記入
TextBox2.Value = _
Worksheets("Sheet2").Cells(1, Lc + 2) _
.CurrentRegion.Rows.Count - 1
End With
Application.ScreenUpdating = True '画面の抑止解除
End Sub
Private Sub CommandButton3_Click()
With ThisWorkbook.Worksheets("Sheet2") 'クリア
.Range("A1:" & Chr((Lc + 69) _
+ (Lc + 2)) & CStr(Lr + 2)).Clear
End With
TextBox1 = ""
TextBox2 = ""
ListBox2.ListIndex = -1
End Sub
back top