Sub Test()
    s = Read_Text("C:\Users\Сергей\Desktop\Контакты.vcf")
    matches = Split(s, "BEGIN:VCARD")
    For n = 1 To UBound(matches)
        s = matches(n)
        s = DecodeQuotedPrintables(s)
    Next
End Sub

Function DecodeQuotedPrintables(inp) As String
    Dim varByteArray(1) As Byte
    inp = UCase(inp)
    inp = Replace(inp, "CHARSET=UTF-8;ENCODING=QUOTED-PRINTABLE:", "")
    Static RegExp As Object
    If RegExp Is Nothing Then
        Set RegExp = CreateObject("VBScript.RegExp")
    End If
    RegExp.Global = True
    RegExp.MultiLine = True
    RegExp.Pattern = "=([A-Z][0-9A-Z])=([0-9A-Z]{2})"
    Set oMatches = RegExp.Execute(inp)
    For n = 0 To oMatches.Count - 1
        varByteArray(0) = Val("&H" & oMatches(n).subMatches(0))
        varByteArray(1) = Val("&H" & oMatches(n).subMatches(1))
        char$ = ConvertBytesToString(varByteArray)
        inp = Replace(inp, oMatches(n).Value, char$)

    Next
    RegExp.Pattern = "=[0-9A-Z]{2}"
    Set oMatches = RegExp.Execute(inp)
    For n = 0 To oMatches.Count - 1
        Vr = Val("&H" & Mid(oMatches(n).Value, 2))

        char$ = Chr(Vr)

        inp = Replace(inp, oMatches(n).Value, char$)

    Next
    inp = Replace(inp, "CHARSET=UTF-8;ENCODING=QUOTED-PRINTABLE:", "")
    inp = Replace(inp, "=", "")

    DecodeQuotedPrintables = inp
End Function

Function ConvertBytesToString(varByteArray)
    Static byt As Object
    Const adTypeText = 2
    Const adTypeBinary = 1
    On Error GoTo ConvertBytesToString_Error
    If byt Is Nothing Then
        Set byt = CreateObject("ADODB.Stream")
    End If
    byt.Type = adTypeBinary
    byt.Open
    byt.Write varByteArray
    byt.Position = 0
    byt.Type = adTypeText
    byt.charSet = "utf-8"
    ConvertBytesToString = byt.ReadText
    byt.Close
    On Error GoTo 0
    Exit Function

ConvertBytesToString_Error:

End Function