Sub CEL()
    Dim strSql As String
    Dim server As String:   server = "SQL"
    Dim catal1 As String:   catal1 = "Data"
    Dim UserId As String:   UserId = "sa"
    Dim Passwo As String:   Passwo = ""

    Dim con As ADODB.Connection:    Set con = New ADODB.Connection
    Dim rst As ADODB.Recordset:     Set rst = New ADODB.Recordset

    con.Open "Provider=SQLOLEDB;Persist Security Info=False;Password=" & Passwo & ";User ID=" & UserId & ";Initial Catalog=" & catal1 & ";Data Source=" & server

    strSql = "SELECT Count(*)" & _
            " FROM Reg " & _
            " INNER join FORM ON R.FORMID=FORM.FORMID" & _
            " WHERE FORM.Name Like '" & "%"
            
    Dim stroka As Range
    Dim stroki As Range
    Set stroki = ThisWorkbook.Worksheets("Лист1").Range("A1", "A20") ' перебор ячеек, вместо ActiveCell
 
    For Each stroka In stroki
        If Len(stroka.Value) >  0  Then
               rst.Open strSql & stroka & "%" & "'", con, , , adCmdText
               ThisWorkbook.Worksheets("Лист1").Range(stroka.Offset(,  3 ).Address).CopyFromRecordset rst
               rst.Close
        End If
    Next
    
    Set rst = Nothing
    con.Close
    Set con = Nothing
    
End Sub