ステートメント制御文の使用例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