Excelマクロでスマホの連絡先作成

###初めに
自己責任でお願いいたします。
事前に連絡先のバックアップをお勧めします。
Androidでフリガナの指定が？でした。　色々とググりましたが…　結果マクロは未使用です。
###Android ArrowsM03編
![20200504-01.PNG](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/145508/48fc68b2-337f-4b95-a53b-56ba3b0a3819.png)
####作成　↓　GoogleTel.csv
"Name","E-mail Address","Mobile Phone","Business Phone"
"沢村一樹","aaa1@gmail.com","090xxxxyyy1","06yyyyzzz1"
"水野美紀","aaa2@gmail.com","090xxxxyyy2","06yyyyzzz2"
"横山裕","aaa3@gmail.com","090xxxxyyy3","06yyyyzzz3"
"本田翼","aaa4@gmail.com","090xxxxyyy4","06yyyyzzz4"
####インポート
![20200504-02.PNG](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/145508/966a0b9d-42e0-9833-12f3-5d0206ca3da2.png)
####ソース
    Sub cre_CSV()
    Dim strLine As String
    Dim i As Long               '入力行
    Dim j As Long               '入力列
    Dim k As Long               '入力列数
    Dim CSVFile As String
    Dim strText As String
    Dim adoSt As Object
    k = 5
    CSVFile = ActiveWorkbook.Path & "\GoogleTel.csv"
    i = 1
    Set adoSt = CreateObject("ADODB.Stream")
        adoSt.Charset = "UTF-8"
        adoSt.Open
        With Worksheets("TEL")
            Do Until .Cells(i, 2).Value = ""
                If .Cells(i, 1).Value = "〇" Then
                    strText = ""
                    For j = 2 To k - 1
                        strText = strText & """" & .Cells(i, j).Value & """" & ","
                    Next j
                    strText = strText & """" & .Cells(i, k).Value & """"
                    adoSt.WriteText strText, 1
                End If
                '入力行
                i = i + 1
            Loop
        End With
        adoSt.SaveToFile CSVFile, 2
        adoSt.Close
    Set adoSt = Nothing
    MsgBox "完了", vbInformation, "( ..)φメモメモ"
    End Sub

###iOS iPhone11編
![20200504-03.PNG](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/145508/5cc46c8b-0124-80f0-8ba8-ec0e2fefcedb.png)
####作成　↓　vCards.vcf
BEGIN:VCARD
VERSION:3.0
N:i沢村一樹
FN:i沢村一樹
X-PHONETIC-LAST-NAME:サワムライッキ
TEL;TYPE=CELL;TYPE=pref;TYPE=VOICE:090 1234 5678
END:VCARD
BEGIN:VCARD
VERSION:3.0
N:i水野美紀
FN:i水野美紀
X-PHONETIC-LAST-NAME:ミズノミキ
TEL;TYPE=CELL;TYPE=pref;TYPE=VOICE:070 1234 5678
END:VCARD
BEGIN:VCARD
VERSION:3.0
N:i横山裕
FN:i横山裕
X-PHONETIC-LAST-NAME:ヨコヤマユウ
TEL;TYPE=CELL;TYPE=pref;TYPE=VOICE:070 1111 2222
END:VCARD
BEGIN:VCARD
VERSION:3.0
N:i本田翼
FN:i本田翼
X-PHONETIC-LAST-NAME:ホンダツバサ
TEL;TYPE=CELL;TYPE=pref;TYPE=VOICE:070 2222 3333
END:VCARD
####VCardを読み込む
![20200504-04.PNG](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/145508/aa0bbf00-928b-9179-369d-076dfc473648.png)
####ソース
    Sub cre_vCards()
    Dim strLine As String
    Dim i As Long               '入力行
    Dim vcfFile As String
    Dim adoSt As Object
    vcfFile = ActiveWorkbook.Path & "\vCards.vcf"
    i = 2
    Set adoSt = CreateObject("ADODB.Stream")
        adoSt.Charset = "UTF-8"
        adoSt.Open
        With Worksheets("TEL")
            Do Until .Cells(i, 2).Value = ""
                If .Cells(i, 1).Value = "〇" Then
                    adoSt.WriteText "BEGIN:VCARD", 1
                    adoSt.WriteText "VERSION:3.0", 1
                    adoSt.WriteText "N:" & .Cells(1, 6).Value & .Cells(i, 2).Value, 1
                    adoSt.WriteText "FN:" & .Cells(1, 6).Value & .Cells(i, 2).Value, 1
                    adoSt.WriteText "X-PHONETIC-LAST-NAME:" & .Cells(i, 3).Value, 1
                    adoSt.WriteText "TEL;TYPE=CELL;TYPE=pref;TYPE=VOICE:" & .Cells(i, 4).Value, 1
                    adoSt.WriteText "END:VCARD", 1
                End If
                '入力行
                i = i + 1
            Loop
        End With
        adoSt.SaveToFile vcfFile, 2
        adoSt.Close
    Set adoSt = Nothing
    MsgBox "完了", vbInformation, "( ..)φメモメモ"
    End Sub