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

###初めに
自己責任でお願いいたします。
事前に連絡先のバックアップをお勧めします。
Androidでフリガナの指定が？でした。　色々とググりましたが…　結果マクロは未使用です。
###Android ArrowsM03編

####作成　↓　GoogleTel.csv
"Name","E-mail Address","Mobile Phone","Business Phone"
"沢村一樹","[e-mail]","090xxxxyyy1","06yyyyzzz1"
"水野美紀","[e-mail]","090xxxxyyy2","06yyyyzzz2"
"横山裕","[e-mail]","090xxxxyyy3","06yyyyzzz3"
"本田翼","[e-mail]","090xxxxyyy4","06yyyyzzz4"
####インポート

####ソース
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編

####作成　↓　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を読み込む

####ソース
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