【Excel VBA】Outlookの連絡先をエクセルシートで取得する

Public Sub アドレス帳インポート()
    Dim アウトルック As Object, 名前空間 As Object, フォルダ As Object, 連絡先 As Object, r As Object
    Dim フィールド名 As Variant, アドレス帳() As Variant
    Dim フィールド数 As Long, フィールド行 As Long, i As Long, k As Long

    Application.ScreenUpdating = False
    Set アウトルック = CreateObject("Outlook.Application")

    With wsアドレス 'ワークシートのオブジェクト名を変更して下さい
        .Range("A1").CurrentRegion.Clear
        フィールド名 = Array("名前", "表示名", "電子メールアドレス")　'好きなフィールド名に書き換え
        For i = 0 To UBound(フィールド名)
            .Cells(1, i + 1).Value = フィールド名(i)
        Next i
        フィールド数 = UBound(フィールド名) + 1
        With .Range("A1").Resize(1, フィールド数)
            .Font.Bold = True
            .Font.ColorIndex = 10
            .Font.Size = 11
        End With

        Set 名前空間 = アウトルック.GetNamespace("MAPI")
        Set フォルダ = 名前空間.GetDefaultFolder(10)
        Set 連絡先 = フォルダ.Items

        フィールド行 = 0

        ReDim アドレス帳データ(フォルダ.Items.Count, フィールド数)

        For Each r In 連絡先
            With r
                アドレス帳 = Array(.Subject, .Email1DisplayName, .Email1Address)　'ContactItemプロパティ
            End With
            If TypeName(r) = "ContactItem" Then
                For k = 0 To UBound(アドレス帳)
                    アドレス帳データ(フィールド行, k) = アドレス帳(k)
                Next k
                フィールド行 = フィールド行 + 1
            End If
        Next r

        .Range("A2").Resize(フォルダ.Items.Count, フィールド数) = アドレス帳データ

        Set r = Nothing
        Set 連絡先 = Nothing
        Set フォルダ = Nothing
        Set 名前空間 = Nothing
        Set アウトルック = Nothing

        .Range("A2", .Cells(2, フィールド数).End(xlDown)).Sort key1:=.Range("A2"), order1:=xlAscending
        .Range(.Columns(1), .Columns(フィールド数)).EntireColumn.AutoFit
    End With
    Application.ScreenUpdating = True
    MsgBox "アドレス帳をインポートしました", vbInformation
End Sub