| |
皆さん、こんにちは。訂正があったので再送です。
>この中にいろんなIDの情報があるとしますが、
>そのなかに同じ番号のIDも入っているとします。
>そこで
>同じIDの情報だけを検索して取り出すにはどのようにしたらいいのでしょうか？
>できたら早く動くようなコードでお願いしたいです。
>よろしくお願いします。
>単純な配列なので特に速い方法はないと思います。
>ループさせて見つけるだけでしょう。
とinoue さんもおっしゃっているように
データ数が多くなければ
逐次検索でもそんなに遅いと感じないと思いますが・・。
BlueさんがおっしゃっているScripting.Dictionaryを使ってみました。
（もっとも私は、普段はCollectionを良く使いますが）。
ユーザー定義型でなければもう少し簡単なのですが、
あえてインターフェースにご指定のユーザー定義型を
使いました（ユーザー定義型にしたのも何か理由があるのでしょうから）。
まず、クラスモジュール（クラス名は 既定のClass1）に
'===========================================================
Option Explicit
Private udsv() As EmployeeRecord
Private udcnt As Long '登録配列数
'===========================================================
Function get_ud(ud As EmployeeRecord, Optional ByVal first As Boolean = False) As Long
Static uidx As Long
If first = True Then
uidx = 1
End If
get_ud = 0
If uidx <= udcnt Then
With ud
.ID = udsv(uidx).ID
.Name = udsv(uidx).Name
.Address = udsv(uidx).Address
.Phone = udsv(uidx).Phone
.HireDate = udsv(uidx).HireDate
End With
uidx = uidx + 1
Else
get_ud = 1
End If
End Function
'===========================================================
Sub put_ud(ud As EmployeeRecord)
ReDim Preserve udsv(1 To udcnt + 1)
With udsv(udcnt + 1)
.ID = ud.ID
.Name = ud.Name
.Address = ud.Address
.Phone = ud.Phone
.HireDate = ud.HireDate
End With
udcnt = udcnt + 1
End Sub
'===========================================================
Private Sub Class_Initialize()
udcnt = 0
End Sub
'===========================================================
Private Sub Class_Terminate()
On Error Resume Next
Erase udsv()
End Sub
次に標準モジュールに
'===========================================================
Private dic As object
Type EmployeeRecord
ID As Integer
Name As String
Address As String
Phone As Long
HireDate As Date
End Type
'===========================================================
Sub open_dic()
'Dictionary オブジェクトのインスタンスを生成し、ユーザー定義型データのデータベースを初期化する
Set dic = CreateObject("Scripting.Dictionary")
End Sub
'===========================================================
Sub close_dic()
'Dictionary オブジェクトの終了
Set dic = Nothing
End Sub
'===========================================================
Function put_dic(ud As EmployeeRecord) As Long
'ユーザー定義型変数EmployeeRecordを登録する
' input : ud--登録するユーザー定義型データ（キーはIDとする）
' output: put_dic:今のところ0が返る
Dim cls1 As Class1
Dim acnt As Long
put_dic = 0
With dic
If .Exists(ud.ID) = False Then
Set cls1 = New Class1
cls1.put_ud ud
.Add ud.ID, cls1
Else
Set cls1 = .Item(ud.ID)
cls1.put_ud ud
End If
End With
End Function
'===========================================================
Function get_dic(ud As EmployeeRecord, Optional ID As Variant = "") As Long
'登録されたユーザー定義型データの中から、指定されたIDのデータを取得する
'Input：ID----取得するユーザー定義型のID（省略すると、前回指定されたIDで取得する）
'output:ud---取得するユーザー定義型データ
' get_dic---0---正常終了 ---1---データの終わり
Static svid As Variant
Static cls1 As Class1
get_dic = 0
Dim cls As Class1
With dic
If ID <> "" Then
If .Exists(ID) = False Then
get_dic = 1
Else
Set cls1 = .Item(ID)
With cls1
get_dic = .get_ud(ud, True)
End With
End If
Else
With cls1
get_dic = .get_ud(ud)
End With
End If
End With
End Function
最後に別の標準モジュールに
'===========================================================
Option Explicit
Sub main()
Dim 顧客情報 As EmployeeRecord
Dim ans As Variant
Dim ret As Long
Call open_dic
'**********************************************************************************************
'サンプル作成
With 顧客情報
.ID = 1
.Name = "aaa"
.Address = "あああああ"
.Phone = 323231111
.HireDate = Date
End With
Call put_dic(顧客情報)
With 顧客情報
.ID = 1
.Name = "bbb"
.Address = "いいいいいい"
.Phone = 311112222
.HireDate = Date + 1
End With
Call put_dic(顧客情報)
With 顧客情報
.ID = 1
.Name = "ccc"
.Address = "うううううう"
.Phone = 333334444
.HireDate = Date + 2
End With
Call put_dic(顧客情報)
With 顧客情報
.ID = 2
.Name = "ddd"
.Address = "えええええええ"
.Phone = 355556666
.HireDate = Date + 3
End With
Call put_dic(顧客情報)
With 顧客情報
.ID = 3
.Name = "eee"
.Address = "おおおおおおおおお"
.Phone = 377778888
.HireDate = Date + 4
End With
Call put_dic(顧客情報)
With 顧客情報
.ID = 2
.Name = "fff"
.Address = "かかかかかかかか"
.Phone = 399990000
.HireDate = Date + 5
End With
Call put_dic(顧客情報)
MsgBox "サンプルデータの作成"
'*************************************************************************************
'
MsgBox "ID=1のデータの取得"
ret = get_dic(顧客情報, 1)
Do While ret = 0
With 顧客情報
MsgBox .ID & vbCrLf & .Name & vbCrLf & .Address & vbCrLf & .Phone & vbCrLf & .HireDate
End With
ret = get_dic(顧客情報)
Loop
'************************************************************************************
MsgBox "ID=2のデータの取得"
ret = get_dic(顧客情報, 2)
Do While ret = 0
With 顧客情報
MsgBox .ID & vbCrLf & .Name & vbCrLf & .Address & vbCrLf & .Phone & vbCrLf & .HireDate
End With
ret = get_dic(顧客情報)
Loop
'************************************************************************************
MsgBox "ID=3のデータの取得"
ret = get_dic(顧客情報, 3)
Do While ret = 0
With 顧客情報
MsgBox .ID & vbCrLf & .Name & vbCrLf & .Address & vbCrLf & .Phone & vbCrLf & .HireDate
End With
ret = get_dic(顧客情報)
Loop
Call close_dic
End Sub
これでmainを実行してみて下さい。
|
|
ichinose
- 06/2/5(日) 12:01 -
