Excel/csv 花名册转 vCard/vcf 通讯录名片并导入手机联系人应用

前言

在整理自己的好友电话号码时，突然产生了这样一个需求：即批量将一个表格中存储的通讯录数据导入手机联系人通讯录中。最简单的办法就是直接将表格文件转换为手机联系人支持的导入格式文件，虽然 Execl 并不支持直接导出通讯录格式文件，但既然有需求，那就肯定有对应的解决办法。

简易实现

搜寻了网上的大多数办法都比较简单，一般只支持电话号码和姓名两个项目。

新建一个 Excel 表格，你可以参考下面的：

姓名,别名,手机,电子邮件,生日,备用邮箱,家庭地址,公司名称,备注
张三,法外狂徒,+86 192 8888 8888,username@email.cn,2001-12-31,username@qq.com,中国北京市法外狂徒看守所,缅北人才 发展署,无

将制作好的表格另存为 CSV(*.csv) 格式，
打开 QQ 邮箱网页版，找到 通讯录 >工具 > 导入联系人文件 ，上传并导入刚刚保存的 CSV(*.csv) 表格文件
等待导入完成后，从 QQ 邮箱 通讯录 >工具 > 导出联系人 导出手机联系人应用支持的 vCard(*.vcf) 格式文件
在手机联系人应用设置中导入该 vCard(*.vcf) 格式文件

很明显的能够感觉到，上面的这种方式虽然可行，但是并不灵活。尽管有其它网站也提供类似的甚至更强大的在线转换功能，但考虑到需要上传文件，有些可能通过服务器进行处理，难免会出现泄露信息等安全风险。

进阶方式

如果不满足上面的效果，可以直接使用 Excel 的宏功能。不过在此之前，我们需要先了解一下 vCard(*.vcf) 文件的格式以及写法：具体请参考这篇文章

BEGIN:VCARD
VERSION:3.0
N:张;三;;;
FN:法外狂徒
TEL;TYPE=CELL:+86 192 8888 8888
BDAY:2001-12-31
EMAIL;TYPE=INTERNET,HOME:username@email.cn
ADR;TYPE=HOME;CHARSET=UTF-8:;;中国北京市法外狂徒看守所;;;;
ORG: 缅北人才发展署
END:VCARD

如果不知道写法，可以直接在手机联系人应用中新建一个联系人，作为模板，填入不会被你混淆的信息，然后导出或分享该联系人文件。使用文本编辑器打开该文件即可。

当然我也做了一个简易的文档表格，请注意开启 Excel 宏功能，否则可能无法正常运行。其中带 * 的是必填项，第二行为演示数据，从第三行开始转换。

*姓,*名,昵称,*手机号,生日,邮箱,家庭住址,工作单位,备注
张,三,法外狂徒,+86 192 8888 8888,2001-12-31,username@email.cn,中国北京市法外狂徒看守所, 缅北人才发展署,无

下面是宏任务的代码：（请根据你的表格格式进行修改）

Sub SaveAsVCard()
    Dim txtFileName As Variant
    Dim lastRow As Long, r As Long
    Dim adoStream As Object
    Dim progressStep As Long

    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    If lastRow < 3 Then
        MsgBox "未找到联系人数据"
        Exit Sub
    End If

    txtFileName = Application.GetSaveAsFilename(FileFilter:="vCard 文件 (*.vcf), *.vcf", Title:="请输入要保存的文件名")
    If txtFileName = False Then Exit Sub

    Set adoStream = CreateObject("ADODB.Stream")
    adoStream.Type = 2 ' Text stream
    adoStream.Charset = "utf-8"
    adoStream.Open
    progressStep = Application.WorksheetFunction.Max(1, (lastRow - 2) \ 20)

    For r = 3 To lastRow
        adoStream.WriteText "BEGIN:VCARD" & vbLf & "VERSION:3.0" & vbLf

        adoStream.WriteText "N:" & Nz(CStr(Cells(r, 1).Value)) & ";" & Nz(CStr(Cells(r, 2).Value)) & ";;;" & vbLf
        If Not IsEmpty(Cells(r, 3).Value) Then 
            adoStream.WriteText "FN:" & Nz(CStr(Cells(r, 3).Value)) & vbLf
        Else
            adoStream.WriteText "FN:" & Nz(CStr(Cells(r, 1).Value)) & " " & Nz(CStr(Cells(r, 2).Value)) & vbLf
        End If
        
        If Not IsEmpty(Cells(r, 4).Value) Then adoStream.WriteText "TEL;TYPE=CELL:" & Nz(CStr(Cells(r, 4).Value)) & vbLf
        If Not IsEmpty(Cells(r, 5).Value) Then adoStream.WriteText "BDAY:" & Nz(CStr(Cells(r, 5).Value)) & vbLf
        If Not IsEmpty(Cells(r, 6).Value) Then adoStream.WriteText "EMAIL;TYPE=INTERNET,HOME:" & Nz(CStr(Cells(r, 6).Value)) & vbLf
        If Not IsEmpty(Cells(r, 7).Value) Then adoStream.WriteText "ADR;TYPE=HOME;CHARSET=UTF-8:;;" & Nz(CStr(Cells(r, 7).Value)) & ";;;;" & vbLf
        If Not IsEmpty(Cells(r, 8).Value) Then adoStream.WriteText "ORG:" & Nz(CStr(Cells(r, 8).Value)) & vbLf
        If Not IsEmpty(Cells(r, 9).Value) Then adoStream.WriteText "NOTE;CHARSET=UTF-8:" & Nz(CStr(Cells(r, 9).Value)) & vbLf
        
        adoStream.WriteText "END:VCARD" & vbLf
        
        If (r - 2) Mod progressStep = 0 Then
            Application.StatusBar = "正在保存联系人数据: " & Format((r - 2) / (lastRow - 2), "0%")
        End If
    Next r

    adoStream.Position = 0
    adoStream.Type = 1 ' Binary stream

    Dim binaryStream As Object
    Set binaryStream = CreateObject("ADODB.Stream")
    binaryStream.Type = 1
    binaryStream.Open
    binaryStream.Write adoStream.Read

    binaryStream.SaveToFile txtFileName, 2
    binaryStream.Close
    adoStream.Close

    Application.StatusBar = False

    Dim msg As String
    msg = "vCard 文件已保存" & vbLf & txtFileName & vbLf & vbLf & "是否打开文件所在目录?"
    If MsgBox(msg, vbYesNo + vbInformation, "文件保存成功") = vbYes Then
        Dim folderPath As String
        folderPath = Left(txtFileName, InStrRev(txtFileName, "\"))
        Shell "explorer.exe /select," & txtFileName, vbNormalFocus
    End If
End Sub

Function Nz(value As Variant, Optional defaultValue As String = "") As String
    If IsEmpty(value) Or IsNull(value) Then
        Nz = defaultValue
    Else
        Nz = CStr(value)
    End If
End Function

如果你懒得制作相应的表格，可以直接用我制作好的现成的：下载 xlsx2vcard.xlsm

一些问题

通过上面这些方法就可以快速将表格花名册转换为可以直接导入手机通讯录的名片文件。如果发现导入失败，比如说提示格式错误什么的，不必理会，格式是没有问题的，但是你需要做一些微小的调整。

使用专业的文本编辑器或代码编辑器，对文件内容的编码、换行符进行修改：

确保保存的文件是没有 BOM 的 UTF-8 编码文件，即 UTF-8 而非 UTF-8 with BOM
修改行尾序列 CRLF 为 LF

修改后，应该就不会有什么问题了

文章目录

Excel/csv 花名册转 vCard/vcf 通讯录名片并导入手机联系人应用

前言

简易实现

进阶方式

一些问题