ステートメント制御文の使用例12


使用例12

リストボックスに複数列を重複なしで表示する (5種類)


 


AdvancedFilter を使う方法
----------------------------
Private Sub UserForm_Initialize()
  'シート検索(データ域:A〜C列, 作業域:D〜F列)
  Range("A1:C11").AdvancedFilter _
  Action:=xlFilterCopy, _
  CopyToRange:=Range("D1:F11"), _
  Unique:=True
    
  'リストボックスを3列に分割
  ListBox1.ColumnWidths = "30;30;30"
  ListBox1.ColumnCount = 3
  
  '重複なしで3列データ表示
  ListBox1.RowSource = Range("D1:F11").Address
  Columns("D:F").Hidden = True  '作業域非表示
End Sub

Private Sub CommandButton1_Click()
  Application.ScreenUpdating = False
  Columns("D:F").Hidden = False
  Columns("D:F").Clear          '作業域再表示
  Unload Me
  Application.ScreenUpdating = True
End Sub
                                                                   bottom top

Find メソッドを使う方法
-------------------------
Private Sub UserForm_Initialize()
  Dim rng As Range
  Dim r As Long
  r = Worksheets("Sheet1").Rows.Count 'シート最終行
  
  'シート検索(データ域:A〜C列, 作業域:D〜F列)
  With Worksheets("Sheet1").Range("A1:A11")
    For i = 1 To 11
    Set rng = .Find(i, LookIn:=xlValues)
      If Not rng Is Nothing Then
        '入力行選択
        Cells(r, 4).End(xlUp).Offset(1, 0).Select
        
        '検索結果を作業域に表示
        Selection.Value = rng.Value
        Selection.Offset(0, 1).Value = _
          rng.Offset(0, 1).Value
        Selection.Offset(0, 2).Value = _
          rng.Offset(0, 2).Value
      End If
    Next i
  End With
  
  'リストボックスを3列に分割
  ListBox1.ColumnWidths = "30;30;30"
  ListBox1.ColumnCount = 3
  
  '1行目タイトル
  Range("D1:F1").Value = Range("A1:C1").Value
  ListBox1.ColumnHeads = True
  
  '重複なしで3列データ表示
  ListBox1.RowSource = Range("D2:F11").Address
  Columns("D:F").Hidden = True  '作業域非表示
End Sub

Private Sub CommandButton1_Click()
  Application.ScreenUpdating = False
  Columns("D:F").Hidden = False
  Columns("D:F").Clear          '作業域再表示
  Unload Me
  Range("A1").Select
  Application.ScreenUpdating = True
End Sub
                                                                   bottom top

Dictionary オブジェクトを使う方法
------------------------------------
Private Sub UserForm_Initialize()
'(データ域:A〜C列, 作業域:D〜F列)

  '二次元配列 g(1, 1)〜g(10, 3) の定義
  Dim g
  g = Worksheets("Sheet1").Cells(1). _
    CurrentRegion.Resize(10, 3).Offset(1).Value
  
  '連想配列(Dictionary)定義 (演習25を参照)
  Dim Dic As Object
  Set Dic = CreateObject("Scripting.Dictionary")
  Dim Mkys As String    'キー定義
  Dim Itms() As String  '値の定義(動的配列)
  
  For i = 1 To 10
    If Not IsEmpty(g(i, 1)) Then
      Mkys = CStr(g(i, 1))          'キー設定
      ReDim Itms(1 To 3) As String
      
      Select Case Dic.Exists(Mkys)  '登録判定
        Case 0    '偽(未登録)
          For j = 1 To 3
            Itms(j) = CStr(g(i, j))
          Next j
        Dic.Add Mkys, Itms          '新規登録
        
        'Case -1  '真(登録済)
      End Select
    End If
  Next i
      
  '辞書登録済キーと値の抽出
  Dim syKey, syItm
  syKey = Dic.Keys   '登録済キー
  syItm = Dic.Items  '登録済の値
  
  For k = 0 To UBound(syKey)
    Cells(k + 2, 4).Resize(, 3) = syItm(k)
  Next k
  
  'リストボックスを3列に分割
  ListBox1.ColumnWidths = "30;30;30"
  ListBox1.ColumnCount = 3
  
  '1行目タイトル
  Range("D1:F1").Value = Range("A1:C1").Value
  ListBox1.ColumnHeads = True
  
  '重複なしで3列データ表示
  ListBox1.RowSource = Range("D2:F11").Address
  Columns("D:F").Hidden = True  '作業域非表示
End Sub

Private Sub CommandButton1_Click()
  Application.ScreenUpdating = False
  Columns("D:F").Hidden = False
  Columns("D:F").Clear          '作業域再表示
  Unload Me
  Range("A1").Select
  Application.ScreenUpdating = True
End Sub
                                                                   bottom top

ADO ドライバ と SQL 文 を使う方法
------------------------------------
Private Sub UserForm_Initialize()
  
  'ADO ドライバーを使用して、エクセルのデータ
  'ファイルをデータベースとし、SQL文 を使って
  '重複なしで3列データをリストに読み込む方法
  '(演習30〜36 を参照)
  
  'VBE-ツール-参照設定において 次をチェック
  'Microsoft ActiveX Data Objects 2.1 Library
  
  Dim Dbs As New ADODB.Connection  'ADOコネクション
  Dim Rc1 As New ADODB.Recordset   'ADOレコードセット1
  Dim Rc2 As New ADODB.Recordset   'ADOレコードセット2
  Dim Rc3 As New ADODB.Recordset   'ADOレコードセット3
  Dim mydbC As String              'エクセルコネクション
  Dim mydbF As String              'エクセルデータファイル
  Dim myQr1 As String              'クエリ文1
  Dim myQr2 As String              'クエリ文2
  Dim myQr3 As String              'クエリ文3
  Dim Rcd As Integer               'エクセルレコード表示行
  
  'エクセルデータファイル指定
  '(事前に作成して、同一フォルダに保存しておく)
  mydbF = "test16fa.xls"
  
  'エクセルデータベース接続設定
  mydbC = _
    "Driver={Microsoft Excel Driver (*.xls)};" & _
    "DBQ=" & ThisWorkbook.Path & "\" & mydbF & ";"
    
  'クエリ文(Group by でグループ化)
  myQr1 = "Select 番号 From [Sheet1$] " & _
          "Group by 番号;"
  myQr2 = "Select 名前 From [Sheet1$] " & _
          "Group by 名前;"
  myQr3 = "Select 所属 From [Sheet1$] " & _
          "Group by 所属;"

  'エクセルデータベース接続
  Dbs.Open "Provider=MSDASQL;" & mydbC
  
  'レコードセットを開く
  Rc1.Open Source:=myQr1, ActiveConnection:=Dbs
  Rc2.Open Source:=myQr2, ActiveConnection:=Dbs
  Rc3.Open Source:=myQr3, ActiveConnection:=Dbs
 
  'エクセルカレントシートに読み込み
    'フィールド名(タイトル行)
    Range("A1").Value = "番号"
    Range("B1").Value = "名前"
    Range("C1").Value = "氏名"
  
    'レコード(データ)表示
    Range("A2").CopyFromRecordset Rc1
    Range("B2").CopyFromRecordset Rc2
    Range("C2").CopyFromRecordset Rc3
     
  'リストボックスに読み込み
    'リストボックスを3列に分割
    ListBox1.ColumnWidths = "30;30;30"
    ListBox1.ColumnCount = 3
    
    '1行目タイトル
    ListBox1.ColumnHeads = True
  
    '重複なしで3列データ転記
    Dt = "A2:C11"
    ListBox1.RowSource = Dt
    
  Rc1.Close
  Rc2.Close
  Rc3.Close
  Dbs.Close
  Set Rc1 = Nothing
  Set Rc2 = Nothing
  Set Rc3 = Nothing
  Set Dbs = Nothing
End Sub

Private Sub CommandButton1_Click()
  Range("A1:C11").Clear
  Unload Me
End Sub
                                                                   bottom top

ADO ドライバ と SQL 文 を使う方法
修正版:レコード(各フィールド)データを同期
---------------------------------------------
Private Sub UserForm_Initialize()
  
  'ADO ドライバーを使用して、エクセルのデータ
  'ファイルをデータベースとし、SQL文 を使って
  '重複なしで3列データをリストに読み込む方法
  
  '修正版:レコード(各フィールド)データを同期
  '抽出データ域:A〜C列, 作業域:D〜F列
    
  'VBE-ツール-参照設定において 次をチェック
  'Microsoft ActiveX Data Objects 2.1 Library
    
  Dim Dbs As New ADODB.Connection  'ADOコネクション
  Dim Rca As New ADODB.Recordset   'ADOレコードセットA
  Dim Rcb As New ADODB.Recordset   'ADOレコードセットB
  Dim mydbC As String              'エクセルコネクション
  Dim mydbF As String              'エクセルデータファイル
  Dim myQra As String              'クエリ文A
  Dim myQrb As String              'クエリ文B
  Dim Rcd As Integer               'エクセルレコード表示行
  
  'エクセルデータファイル指定
  '(事前に作成して、同一フォルダに保存しておく)
  mydbF = "test16fa.xls"
  
  'エクセルデータベース接続設定
  mydbC = _
    "Driver={Microsoft Excel Driver (*.xls)};" & _
    "DBQ=" & ThisWorkbook.Path & "\" & mydbF & ";"
    
  'クエリ文(Group by でグループ化)
  myQra = "Select * From [Sheet1$]"         '全データ
  myQrb = "Select 番号 From [Sheet1$] " & _
          "Group by 番号;"                  '番号のみ
  
  'エクセルデータベース接続
  Dbs.Open "Provider=MSDASQL;" & mydbC
  
  'レコードセットを開く
  Rca.Open Source:=myQra, ActiveConnection:=Dbs
  Rcb.Open Source:=myQrb, ActiveConnection:=Dbs
   
  'エクセルカレントシートに読み込み
  
  With Rca  '全データ読み込み
    'フィールド名(タイトル行)
    For i = 1 To .Fields.Count
      Cells(1, i + 3).Value = .Fields(i - 1).Name
    Next i
    
    'レコード(データ)表示
    Range("D2").CopyFromRecordset Rca
    Columns("D:F").Hidden = True  '作業域非表示
    .Close
  End With
  
  With Rcb  '番号のみ重複なしで読み込み
    'フィールド名(タイトル行)
    For i = 1 To .Fields.Count
      Cells(1, i).Value = .Fields(i - 1).Name
    Next i

    'レコード(データ)表示
    Range("A2").CopyFromRecordset Rcb
    .Close
  End With
  
  'VLOOKUP関数実行
  'Cells(1, 2).Value = "=If(A1="""","""",VLOOKUP(A1,$D$1:$F$11,2))"
  'Cells(2, 2).Value = "=If(A2="""","""",VLOOKUP(A2,$D$1:$F$11,2))"
  '                  :
    For j = 1 To 11
      For k = 2 To 3
        Cells(j, k).Value = "=If(A" & CStr(j) & _
          "="""","""",VLOOKUP(A" & CStr(j) & _
          ",$D$1:$F$11," & CStr(k) & "))"
      Next k
    Next j
     
  'リストボックスに読み込み
    'リストボックスを3列に分割
    ListBox1.ColumnWidths = "30;30;30"
    ListBox1.ColumnCount = 3
    
    '1行目タイトル
    ListBox1.ColumnHeads = True
  
    '重複なしで3列データ転記
    Dt = "A2:C11"
    ListBox1.RowSource = Dt
    
  Dbs.Close
  Set Rca = Nothing
  Set Rcb = Nothing
  Set Dbs = Nothing
End Sub

Private Sub CommandButton1_Click()
  Application.ScreenUpdating = False
  Columns("D:F").Hidden = False      '作業域再表示
  Columns("A:F").Clear
  Application.ScreenUpdating = True
  Unload Me
End Sub

                                                                   back top