WHERE ANKETA_ID=4362;

EXECUTE [MainDWH].[dbo].[sp_AfsSOAP_Request]
@BP_ID
,@lastName
,@firstName
,@secondName
,@birthDate
,@sex
,@seriesNumber
,@docdate
,@AfsMessage OUTPUT

SELECT BP_ID  AfsMessage

Create Procedure dbo.MyProcedure @Where int, @Result nvarchar(max) Output
As
Begin
-- здесь ваш код ХП
End;

Public Sub test()
    Dim rs As New ADODB.Recordset, conn As New ADODB.Connection, pCom As ADODB.Command
    Dim whereId As Long
    conn.Open "Connection string settings"
    
    'Получаем значение параметра для ХП запросом к таблице в базе
    rs.Open "Select UserId From MyDb.dbo.Users Where UserName = '" & ActiveSheet.Range("A2").Value & "';", conn
    whereId = rs(0).Value
    rs.Close
    
    'настраиваем вызов ХП и её параметры
    Set pCom = New ADODB.Command
    Set pCom.ActiveConnection = conn
    pCom.Parameters.Append pCom.CreateParameter("@Where", adInteger, adParamInput, Value:=whereId)
    pCom.Parameters.Append pCom.CreateParameter("@Result", adVarWChar, adParamOutput, 65000)
    pCom.CommandType = adCmdStoredProc
    pCom.CommandText = "MyDb.dbo.MyProcedure"
    'выполняем ХП
    pCom.Execute Option:=adExecuteNoRecords
    
    Debug.Print "Результат выполнения " & pCom.Parameters("@Result").Value
    Set pCom = Nothing
    conn.Close
    Set conn = Nothing
End Sub

Dim Conn
Dim Ary()
'------------------------------------------------------------------------------------------------------------------
Sub test_conn()

'Dim Prm       As ADODB.Parameter
Dim cmd       As ADODB.Command
Dim Conn      As ADODB.Connection
Dim rs        As ADODB.Recordset
Dim lLastrow, i As Long
Dim iCell       As Range
Dim whereID     As Long
'------------------------------------------------------------------------------------------------------------------
Application.ScreenUpdating = False
Range("G2:G65536").Clear
lLastrow = Cells(Rows.Count, 2).End(xlUp).Row
i = 1
'------------------------------------------------------------------------------------------------------------------
Set Conn = New ADODB.Connection
Conn.ConnectionString = "driver={SQL Server};server=177.17.3.176;uid=           ;pwd=         ;database=MainDWH"
Conn.Open
'------------------------------------------------------------------------------------------------------------------

With ThisWorkbook.Worksheets(1)

For Each iCell In .Range("B2", Cells(lLastrow, 2))
whereID = iCell.Value
Set cmd = New ADODB.Command
     With cmd
          .ActiveConnection = Conn
          .Parameters.Append cmd.CreateParameter("@ID", adInteger, adParamInput, Value:=whereID)
          .CommandType = adCmdStoredProc
          .CommandText = "port.AFSMESS"
     End With
     Set rs = cmd.Execute()
     i = i + 1
     Cells(i, 7).CopyFromRecordset rs
        Set cmd = Nothing
        If iCell = "" Then
        Cells(i, 7).Value = ""
        End If
Next
End With
Application.ScreenUpdating = True
'------------------------------------------------------------------------------------------------------------------
'Conn.Close
'rs.Close
'Set rs = Nothing
'Set con = Nothing
End Sub