Sub pr()

Dim cn As New ADODB.Connection
Dim cm As New ADODB.Command
Dim rs As New ADODB.Recordset
Dim fldLoop As Field
Dim i As Integer
Dim ws As Worksheet

' переменные для сохранения фильтров и флажок "отфильтровано" 
Dim arrFilters
Dim sFilterRange$
Dim boolFilter As Boolean

Set ws = Sheets( 1 )
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

cn.Provider = "Microsoft.Jet.OLEDB.4.0"
cn.ConnectionString = "Data Source = D:\Книга3; Extended Properties=Excel 8.0;"
cn.Open
cm.ActiveConnection = cn
cm.CommandText = "SELECT Исполнитель FROM [Лист1$]"
rs.Open cm
' цикл тут явно не к месту
' Do While Not rs.EOF
' rs.MoveNext

Call SaveFilters(ws, sFilterRange, boolFilter, arrFilters)
ws.Range("J" &  2 ).CopyFromRecordset rs
Call RestoreFilters(ws, sFilterRange, boolFilter, arrFilters)
If IsArray(arrFilters) Then Erase arrFilters

' Loop

rs.Close
cn.Close
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub

' **** сохраниение фильтров ****
Sub SaveFilters(w As Worksheet, currentFiltRange$, boolFiltered As Boolean, filterArray)
Dim f%
If Not w.AutoFilterMode Then Exit Sub

With w.AutoFilter
    currentFiltRange = .Range.Address
    With .filters
        ReDim filterArray( 1  To .Count,  1  To  3 )
        For f =  1  To .Count
            With .Item(f)
                If .On Then
                    boolFiltered = True
                    filterArray(f,  1 ) = .Criteria1
                    If .Operator Then
                        filterArray(f,  2 ) = .Operator
                        filterArray(f,  3 ) = .Criteria2
                    End If
                End If
            End With
        Next
    End With
End With
If boolFiltered Then w.AutoFilterMode = False
End Sub

' **** восстановление фильтров ****
Sub RestoreFilters(w As Worksheet, currentFiltRange$, boolFiltered As Boolean, filterArray)
Dim col%
If Not boolFiltered Then Exit Sub

w.AutoFilterMode = False
For col =  1  To UBound(filterArray,  1 )
    If Not IsEmpty(filterArray(col,  1 )) Then
        If filterArray(col,  2 ) Then
            w.Range(currentFiltRange).AutoFilter field:=col, _
                Criteria1:=filterArray(col,  1 ), _
                    Operator:=filterArray(col,  2 ), _
                Criteria2:=filterArray(col,  3 )
        Else
            w.Range(currentFiltRange).AutoFilter field:=col, _
                Criteria1:=filterArray(col,  1 )
        End If
    End If
Next
End Sub