Dim s As String
    
    s = "{\rtf1\par " _
        & "\trowd \trgaph30\trleft-30\trrh262\cellx980\cellx1991\cellx3001 " _
        & "\intbl \qr \f0\fs20 \cf Проверка\cell \qr 2\cell\qr 3\cell \intbl \row " _
        & "\trowd \trgaph30\trleft-30\trrh262\cellx980\cellx1991\cellx3001 " _
        & "\intbl \qr \f0\fs20 \cf 4\cell \qr 5\cell\qr 6\cell \intbl \row} "

    Clipboard.Clear
    Clipboard.SetText s, vbCFRTF

Public Sub SetClipboardTableRTF(r As ADODB.Recordset)
    Dim sb As New StringBuilder, f As ADODB.Field, sr As String, _
        s As String, ss As String, b As Boolean, sf As String, i As Long

    sb.AppendLine "{\rtf1\par "
    
    For Each f In r.Fields
        Select Case f.Type
            Case adCurrency
                i = i +  1500 
            Case adTinyInt, adSmallInt, adInteger
                i = i +  1200 
            Case adSingle, adDouble
                i = i +  1500 
            Case adDate, adDBTimeStamp
                i = i +  1500 
            Case adBoolean
                i = i +  700 
            Case Else
                i = i +  2500 
        End Select
        sr = sr & "\cellx" & i
    Next f
    sr = "\trowd \trgaph30\trleft-30\trrh262" & sr & " "

    Do Until r.EOF
        sb.AppendLine sr
        b = True
        For Each f In r.Fields
            Select Case f.Type
                Case adCurrency
                    s = "r": sf = "#,##0.00"
                Case adTinyInt, adSmallInt, adInteger
                    s = "r": sf = "#,##0"
                Case adSingle, adDouble
                    s = "r": sf = "#,##0.000"
                Case adDate, adDBTimeStamp
                    s = "c": sf = "Short Date"
                Case adBoolean
                    s = "c": sf = "b"
                Case Else
                    s = "l": sf = vbNullString
            End Select
            If IsNull(f) Then
                ss = "\cell"
            Else
                If Len(sf) Then
                    If sf = "b" Then
                        ss = IIf(f, "Да", "Нет") & "\cell"
                    Else
                        ss = Replace(Format$(f, sf), "\", "\\") & "\cell"
                    End If
                Else
                    ss = Replace(f, "\", "\\") & "\cell"
                End If
            End If
            If b Then
                sb.Append "\intbl \q" & s & " \f0\fs20 \cf " & ss: b = False
            Else
                sb.Append "\q" & s & " " & ss
            End If
        Next f
        sb.AppendLine " \intbl \row "
        r.MoveNext
    Loop
    sb.AppendLine "}"
    
    Clipboard.Clear
    Clipboard.SetText sb.Value, vbCFRTF
End Sub