Function F_Exec_SQL_ToRcdSet(ConString As String, CommandText As String) As ADODB.Recordset
' Процедура выполняет SQL запрос, результат которого возвращает как Recordset

    'ConString - строка подключения
    'CommandText - текст запроса
    
    Dim Cmd As ADODB.Command
    Dim Con As Connection
    
    Set Con = New ADODB.Connection
        Con.CommandTimeout = 1000000
        Con.ConnectionString = ConString
        Con.CursorLocation = adUseClient
    Con.Open
    
    Set Cmd = CreateObject("ADODB.Command")
        Cmd.CommandTimeout = 1000000
        Cmd.CommandType = adCmdText
        Cmd.ActiveConnection = Con

    Set Exec_SQL_ToRcdSet = Con.Execute(CommandText)

End Function

Sub Calc_InSql_MapingOrgName_Put_ToExcel_Forum()
    ' Строка подключения
    Dim ConString As String
        ConString = "Driver=SQL " & "Server;Server=N01000039;Database=TD"
    ' Текст команды SQL запроса
    Dim CommandText As String
    ' Массив параметров необходимых для выполнения SQL запроса. Из него формируется CommandText
    Dim MasParams() As String
    ReDim MasParams(1 To 1000, 1 To 5)

    CommandText = F_CommandText("EXEC", "[dbo].[SP_Report_Дебиторка_Organisation_WithoutMaping]", MasParams())
        DoEvents
    Dim RcdSet As ADODB.Recordset
    Set RcdSet = F_Exec_SQL_ToRcdSet(ConString, CommandText)
 
    CountCol = Val(RcdSet.Fields.Count)
    CountRow = Val(RcdSet.RecordCount)

End Sub

Option Explicit

Sub Calc_InSql_MapingOrgName_Put_ToExcel_Forum()

    ' Строка подключения
    Dim ConString As String
        ConString = "Driver=SQL " & "Server;Server=N01000039;Database=TD"
    ' Текст команды SQL запроса
    Dim CommandText As String
    ' Массив параметров необходимых для выполнения SQL запроса. Из него формируется CommandText
    Dim MasParams() As String
    ReDim MasParams(1 To 1000, 1 To 5)

    CommandText = F_CommandText("EXEC", "[dbo].[SP_Report_Дебиторка_Organisation_WithoutMaping]", MasParams())

        DoEvents
    ' В этот курсор попадают организации, по которым нет мапинга в SQL - таблице.
    Dim RcdSet As ADODB.Recordset
    Set RcdSet = F_Exec_SQL_ToRcdSet(ConString, CommandText)
    
    Dim CountCol, CountRow As Integer
    CountCol = Val(RcdSet.Fields.Count)
    CountRow = Val(RcdSet.RecordCount)

End Sub

Function F_Exec_SQL_ToRcdSet(ConString As String, CommandText As String) As ADODB.Recordset
' Процедура выполняет SQL запрос, результат которого возвращает как Recordset

    'ConString - строка подключения
    'CommandText - текст запроса
    
    Dim Cmd As ADODB.Command
    Dim Con As Connection
    
    Set Con = New ADODB.Connection
        Con.CommandTimeout = 1000000
        Con.ConnectionString = ConString
        Con.CursorLocation = adUseClient
    Con.Open
    
    Set Cmd = CreateObject("ADODB.Command")
        Cmd.CommandTimeout = 1000000
        Cmd.CommandType = adCmdText
        Cmd.ActiveConnection = Con
    
    Dim RcdSet As New ADODB.Recordset
    Set RcdSet = Con.Execute(CommandText)

End Function


Function F_CommandText(TypeComand As String, SqlObject As String, MasParams() As String)
' Ф-ция возвращающая SQL-команду

    ' TypeComand - Тип SQL команды: INSERT; EXEC
    ' SqlObject  - Объект SQL, который участвует в SQL - запросе
    ' StrParams  - Мыссив параметров, содержащий значения параметров небходивых для SQL - запроса
    
    Dim CommandText As String ' Текст SQL команды
    Dim StrParams As String  ' Сконкатенированная строка параметров
    Dim x, y, i As Integer
    
    x = UBound(MasParams, 1)
    y = UBound(MasParams, 2)
    
    If x = 1 Then
        StrParams = "'"
        For i = 1 To y
            StrParams = StrParams & MasParams(1, i)
            If i < y Then
            StrParams = StrParams & "', '"
            End If
        Next
        StrParams = StrParams & "'"
    ElseIf x = 1000 Then
        StrParams = " "
    End If
    
    If TypeComand = "INSERT" Then
        CommandText = "INSERT INTO " & SqlObject & " VALUES (" & StrParams & ")"
    ElseIf TypeComand = "EXEC" Then
        CommandText = "EXEC " & SqlObject & StrParams
    End If
    
    F_CommandText = CommandText

End Function