Private Sub Works()
    Dim FConn As New ADODB.Connection, pFilter As New ADODB.Recordset, sSQL As String
    sSQL = "SELECT Город1 "
    For n = 2 To 21
        sSQL = sSQL & ",Город" & n
    Next
    sSQL = sSQL & " FROM Rap ORDER BY Rap.Work;"
    sPath = ThisWorkbook.Path & "\RAP.mdb"
    FConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sPath & ";"
    Set pFilter = FConn.Execute(sSQL)
    If Not pFilter.EOF Then
        Range("C8").CopyFromRecordset pFilter
    End If
    Set pFilter = Nothing
    FConn.Close:
    Set FConn = Nothing
End Sub

Sub test()
Dim sCon As String, sSql As String
Dim cn  As Object, p, sPath, rs As Object, m
p = ThisWorkbook.Path
sPath = p & "\RAP.mdb"
sCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sPath
'Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
sSql = "SELECT * From Rap Where [Data]=" & "#" & Format(Sheets("РАПОРТ").Range("K3").Value, "mm\/dd\/yyyy") & "#" & ""
        
rs.Open sSql, sCon, adOpenStatic
With Sheets("РАПОРТ")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

'On Error Resume Next
'a = rs.GetRows
Do While Not rs.EOF
For Each fld In rs.Fields   '.Count
If fld.Name <> "ID" And fld.Name <> "Work" And fld.Name <> "Data" Then
For Each cl In Sheets("РАПОРТ").Range("C7:X7")
    If cl.Value = fld.Name Then
        For r = 8 To LastRow
        m = Replace(Sheets("РАПОРТ").Cells(r, 2).Value, "Работа", "")
        If m = rs.Fields(1).Value Then
            If fld.Value <> 0 Then
            Sheets("РАПОРТ").Cells(r, cl.Column).Value = fld.Value
            End If
        End If
        Next
    End If
Next
End If
Next
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
End Sub