Code 23

演習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)
  
  '行列の挿入削除が可能な選択型を取得
  'リストボックス１
  Ds = "A2:B" & Lr                    '選択元の番号と名前
  ListBox1.ColumnHeads = True         '１行目タイトル
  ListBox1.ColumnWidths = "40;60"
  ListBox1.ColumnCount = 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)
  
  'リストボックス２
  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 の１行目タイトル表示
  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
演習23 のユーザーフォーム コード

演習23 のユーザーフォームコード
