=ЛЕВСИМВ(ПРАВСИМВ(Запрос в AD;44);14)

Function GetADInfo(ByVal SearchField, ByVal SearchString, ByVal ReturnField)

Dim adoCommand, strDomain, objConnection

strDomain = "dc=Ваш_домен,dc=local"

Set objConnection = CreateObject("ADODB.Connection")

objConnection.Open "Provider=ADsDSOObject;"

Set adoCommand = CreateObject("ADODB.Command")

adoCommand.ActiveConnection = objConnection

adoCommand.CommandText = _
 "<LDAP://" & strDomain & ">;(&(objectCategory=" & "User" & ")" & _
 "(" & SearchField & "=" & SearchString & "));" & SearchField & "," & ReturnField & ";subtree"

Dim objRecordSet

Set objRecordSet = adoCommand.Execute

If objRecordSet.RecordCount = 0 Then

GetADInfo = "not found"

Else

GetADInfo = objRecordSet.Fields(ReturnField)
End If

objConnection.Close

Set objRecordSet = Nothing

Set objCommand = Nothing

Set objConnection = Nothing

End Function

Private Sub Create_VCF()
    'Open a File in Specific Path in Output or Append mode
    Dim FileNum As Integer
    Dim iRow As Double
    iRow = 2
    FileNum = FreeFile
    OutFilePath = "D:\OutputVCF.VCF"
    Open OutFilePath For Output As FileNum
 
    'Loop through Excel Sheet each row and write it to VCF File
    While VBA.Trim(Sheets("Sheet1").Cells(iRow, 1)) <> ""
        LName = VBA.Trim(Sheets("Sheet1").Cells(iRow, 1))
        FName = VBA.Trim(Sheets("Sheet1").Cells(iRow, 2))
        PhNum = VBA.Trim(Sheets("Sheet1").Cells(iRow, 3))
 
        Print #FileNum, "BEGIN:VCARD"
        Print #FileNum, "VERSION:3.0"
        Print #FileNum, "N:" & LName & ";" & FName & ";;;"
        Print #FileNum, "FN:" & LName & " " & FName
        Print #FileNum, "TEL;TYPE=CELL;TYPE=PREF:" & PhNum
        Print #FileNum, "END:VCARD"
        iRow = iRow + 1
    Wend
 
    'Close The File
    Close #FileNum
    MsgBox "Contacts Converted to Saved To: " & OutFilePath & " 
End Sub

Private Sub Add_Click()
Dim iRow As Integer

SNP = TextSNP.Value
Birthday = TextBirthday.Value
Adress = TextAdress.Value
personal_account = TextPersonal_account.Value

With Base_all
 iRow = .ListObjects("Tablbase_all").DataBodyRange.Rows.Count + 5
 
 '.Cells(iRow, "A").Value = SNP
 '.Cells(iRow, "B").Value = Birthday
 '.Cells(iRow, "C").Value = Adress
 '.Cells(iRow, "E").Value = personal_account
End With

End Sub

ActiveSheet.OLEObjects.Add(Filename:="C:\Тест\1.pdf").Activate