Option Explicit
Dim cmd As New ADODB.Command


Sub DeleteRows()
'
' Макрос1 Макрос
' Макрос записан 14.01.2009 (user)
'

'
Dim sCurrentFiltRange As String, sXml As String, sSql As String
Dim r As Range
Dim shUnique As Worksheet, sh As Worksheet, w As Workbook, w1 As Workbook
Dim vGroup As Variant

On Error GoTo labErr

Set w = Application.ActiveWorkbook
Set sh = Application.ActiveSheet  ' лист на котором нужно удалять строки
If sh.AutoFilter Is Nothing Then
    MsgBox "Установите автофильтр"
    Exit Sub
End If

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

sCurrentFiltRange = sh.AutoFilter.Range.Address

Set w1 = Application.Workbooks.Add
Application.DisplayAlerts = False
Set shUnique = CheckSheet(w1, "Уникальные")
' Получаем список уникальных данных из столбца
Set r = w1.Worksheets("Уникальные").Range("a1")
sh.Range("A:A").AdvancedFilter xlFilterCopy, , r, True
DoEvents
' Получаем уникальный список в массив для обработки
vGroup = r.Range("a2:F" + CStr(r.SpecialCells(xlCellTypeLastCell).Row)).Value2
' Книга больше не нужна, закрываем
Set r = Nothing
w1.Close False
Set w1 = Nothing
Application.DisplayAlerts = True

' Строим из массива данных XML, который запросим на сервере и по результатам получим что удалять
sXml = "<?xml version = ""1.0"" encoding=""Windows-1251"" standalone=""yes""?><VBA><kk>"
sXml = sXml & Join(vGroup, "</a><a>")
sXml = Left(sXml, Len(sXml) - 3) & "</kk></VBA>"

Dim rs As Recordset
Set rs = CheckDataFromSQL(sXml)
' Теперь беГим циклом по рекордсету, применяем автофильтр и видимые строки удаляем
rs.MoveFirst
While Not rs.EOF
    With sh.Range(sCurrentFiltRange)
        ' Работаем с автофильтром
        .AutoFilter Field:=1, Criteria1:=rs.fields(0).Value
        DoEvents
        ' Удаляем видимые строки
        .SpecialCells(xlCellTypeVisible).EntireRow.Delete
    End With
    rs.MoveNext
Wend
rs.Close
Set rs = Nothing
Set cmd = Nothing
    MsgBox "Закончили!"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
labErr:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Что-то не получилось, данные не обработаны! Ошибка - " & Err.Description, vbCritical + vbOKOnly
End Sub

Private Function CheckSheet(w As Workbook, sName As String, Optional bCreate As Boolean = True) As Worksheet
Dim b As Boolean
b = Application.DisplayAlerts
Application.DisplayAlerts = False
On Error GoTo labErr
' Если есть лист пытаемся удалить его
w.Sheets(sName).Delete
If bCreate Then
' Если удалили и нужно создавать, создаем и возвращаем
    Set CheckSheet = w.Sheets.Add
    CheckSheet.Name = sName
End If
Application.DisplayAlerts = b
Exit Function
labErr:
Application.DisplayAlerts = b
If bCreate Then
' Если нужно создавать, создаем и возвращаем
    Set CheckSheet = w.Sheets.Add
    CheckSheet.Name = sName
End If
End Function

Private Function CheckDataFromSQL(sXml As String) As Recordset
Dim sql As String
sql = "DECLARE @idoc INT " & vbCrLf _
    & "EXEC sp_xml_preparedocument @idoc OUTPUT, " & vbCrLf _
    & "     ? " & vbCrLf _
    & "      " & vbCrLf _
    & "SELECT distinct dp.BDNAME " & vbCrLf _
    & "FROM   Base_001.dbo.BD_Processed dp " & vbCrLf _
    & "       INNER JOIN OPENXML(@idoc, 'VBA/kk', 2) " & vbCrLf _
    & "            WITH(a VARCHAR(255)) a ON dp.BDNAME = a.a " & vbCrLf _
    & " " & vbCrLf _
    & "EXEC sp_xml_removedocument @idoc"
Dim prm As ADODB.Parameter
' Define a Command object for a stored procedure.
cmd.ActiveConnection = "Provider=sqloledb;Data Source=_TVOI_SERVER_;Initial Catalog=Base_001;Integrated Security=SSPI;"
cmd.CommandText = sql
cmd.CommandType = adCmdText
cmd.CommandTimeout = 15
' Set up new parameter for the stored procedure.
Set prm = cmd.CreateParameter("sxml", adVarChar, adParamInput, 8000, sXml)
cmd.Parameters.Append prm
' Create a record set by executing the command.
Set CheckDataFromSQL = cmd.Execute
' Тут можно сделать обработку ошибок, но под рукой нет, а искать нет времени. Если нужно сам разберёшся
End Function