事務屋さんの備忘録

主にプログラミングのことを書いていきます。メモというか備忘録的な感じで。プログラミングといっても、私はプロのエンジニアでも本職のプログラマーでもありません。単なる事務職をやってるサラリーマンで、空いた時間にちょこちょこっとプログラミングしてる程度です。よってこのブログに記載したことが誤っていたり、もっとよい方法がある場合もあると思います。その場合には、ご指摘いただけると嬉しいです。また、このブログを読んで役に立った、なんて方がいらっしゃったら幸いですね。

Excel VBA Dictionaryのitemにクラスのインスタンスを格納する

メモ。
クラスモジュール Person

Option Explicit

Private intAge       As Integer
Private strLastName  As String
Private strFirstName As String

Public Property Let Age(ByVal value As Integer)
 
    intAge = value
 
End Property
 
Public Property Get Age() As Integer
 
    Age = intAge
    
End Property

Public Property Let LastName(ByVal value As String)
 
    strLastName = value
 
End Property
 
Public Property Get LastName() As String
 
    LastName = strLastName
    
End Property

Public Property Let FirstName(ByVal value As String)
 
    strFirstName = value
 
End Property
 
Public Property Get FirstName() As String
 
    FirstName = strFirstName
    
End Property


標準モジュール

Option Explicit

Dim myDic      As New Scripting.Dictionary

Dim i          As Long
Dim lngY       As Long
Dim lngLastRow As Long

Sub Test()
    
    Dim p As Person
    
    Application.ScreenUpdating = False
    
    lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    For i = 2 To lngLastRow
    
        Set p = New Person
        
        p.Age = CStr(Cells(i, 4))
        p.LastName = CStr(Cells(i, 2))
        p.FirstName = CStr(Cells(i, 3))

        myDic.Add CStr(Cells(i, 1)), p  'Noをキーにクラスを読み込み
        
        Set p = Nothing
        
    Next

    
    '格納できているかテスト
    lngLastRow = Cells(Rows.Count, 6).End(xlUp).Row
    
    For i = 2 To lngLastRow
    
        Cells(i, 7) = myDic(CStr(Cells(i, 6))).LastName  'Noをキーに姓を書き出す
        Cells(i, 8) = myDic(CStr(Cells(i, 6))).FirstName 'Noをキーに名を書き出す
        Cells(i, 9) = myDic(CStr(Cells(i, 6))).Age       'Noをキーに年齢を書き出す
    
    Next
    
    Set myDic = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "完了!"
    
    End
    
    '参考URL
    'http://www.iwana.to/~sakauchi/diary/?20040701
    
End Sub

f:id:freefly3104:20180125214834j:plain