Set rsFlt = New ADODB.Recordset
   rsFlt.Fields.Append "Вкладка", adChar,  3 
   rsFlt.Fields.Append "Галка", adBoolean
   rsFlt.Fields.Append "Параметр", adVarChar,  20 
   rsFlt.Fields.Append "Условие", adInteger, , adFldIsNullable
   rsFlt.Fields.Append "Значение1", adDouble, , adFldIsNullable
   rsFlt.Fields.Append "Значение2", adDouble, , adFldIsNullable
   rsFlt.Open , , adOpenStatic, adLockBatchOptimistic
'Данные по Мехдобыче
   rsFlt.AddNew Array("Вкладка", "Условие", "Галка", "Параметр"), Array("НФРаб", Null, False, "Qж")
   rsFlt.AddNew Array("Вкладка", "Условие", "Галка", "Параметр"), Array("ДобРаб", Null, False, "Qн")
   rsFlt.AddNew Array("Вкладка", "Условие", "Галка", "Параметр"), Array("ДобРаб", Null, False, "%H2O")
   rsFlt.AddNew Array("Вкладка", "Условие", "Галка", "Параметр"), Array("ДобРаб", Null, False, "Dштуцера")

rsFlt.Fields.Append "Вкладка", adChar,  3 

do until rs.Eof
 rsFlt.AddNew Array("Вкладка", "Условие", "Галка", "Параметр"), _
  Array(rs.Fields("Вкладка").Value, rs.Fields("Условие").Value, rs.Fields("Галка").Value, rs.Fields("Параметр").Value)
 rsflt.Update
 rs.Movenext
loop

Private Sub btnСорт_Click()
   Dim t1 As Date, t2 As Date
   t1 = Now
   rsx.Sort = "ДАТА"
   t2 = Now
   lblСорт = Format((t2 - t1), "hh:mm:ss")
End Sub

Private Sub btnСтарт_Click()
   Dim t1 As Date, t2 As Date, t3 As Date
   If Not rsx Is Nothing Then Set rsx = Nothing
   Call Создать_rsx
   If rs.State = adStateOpen Then rs.Close
   Screen.MousePointer = ccHourglass
   DoEvents
   t1 = Now
   rs.Open
   t2 = Now
   Do Until rs.EOF
      rsx.AddNew 'Array("ИД", "ДАТА", "ТЕКСТ"), Array(rs.Fields(0), rs.Fields(1), rs.Fields(2))
      rsx.Fields( 0 ) = rs.Fields( 0 )
      rsx.Fields( 1 ) = rs.Fields( 1 )
      rsx.Fields( 2 ) = rs.Fields( 2 )
      rs.MoveNext
   Loop
   t3 = Now
   lblКопирование = Format((t2 - t1) *  60 , "hh:mm:ss")
   lblСчитывание = Format((t3 - t2) *  60 , "hh:mm:ss")
   Label2 = "Всего записей  " & rsx.RecordCount
   Screen.MousePointer = ccDefault
End Sub

Private Sub Form_Load()
   DE1.Conn1.Open
   Set rs = New ADODB.Recordset
   rs.Source = s
   rs.CursorLocation = adUseClient
   rs.ActiveConnection = Conn1
   rs.LockType = adLockReadOnly
   rs.CursorType = adOpenStatic
End Sub

Sub Создать_rsx()
   If Not rsx Is Nothing Then Set rsx = Nothing
   Set rsx = New ADODB.Recordset
   rsx.Fields.Append "ИД", adInteger
   rsx.Fields.Append "ДАТА", adDate
   rsx.Fields.Append "ТЕКСТ", adVarChar,  255 , adFldIsNullable
   rsx.Open
End Sub

For Each f In rs_in.Fields
 If f.Type = adChar Or f.Type = adVarChar Then
  rs_out.Fields.Append f.Name, f.Type, f.DefinedSize, adFldMayBeNull
  ' . . . ElseIf
  ' . . . ElseIf
  ' Для числовых типов задавать DefinedSize не надо
 End If
Next

 If f.Type = adChar Or f.Type = adVarChar Then
  rs_out.Fields.Append f.Name, adVarChar , f.DefinedSize, adFldMayBeNull

Sub СинтетикКлон(ByRef rs_in As ADODB.Recordset, ByRef rs_out As ADODB.Recordset)
   Dim i As Long, k As Long
   Dim f As ADODB.Field
'Отсюда ...
   Set rs_out = Nothing ' 
   Set rs_out = New ADODB.Recordset '
   For Each f In rs_in.Fields ' Создание полей
      If (f.Type = adChar) Or (f.Type = adVarChar) Then
         rs_out.Fields.Append f.Name, f.Type, f.DefinedSize, adFldMayBeNull
      Else
         rs_out.Fields.Append f.Name, f.Type, , adFldMayBeNull
      End If
   Next
   rs_out.Open , , adOpenStatic, adLockBatchOptimistic
'И до этой строчки - создание рекордсета
'Начало копирования данных:
   If rs_in.RecordCount >  0  Then rs_in.MoveFirst    
   k = rs_out.Fields.Count -  1 
   Do Until rs_in.EOF
      rs_out.AddNew
      For i =  0  To k
         rs_out.Fields(i).Value = rs_in.Fields(i).Value
      Next
      rs_in.MoveNext
   Loop
End Sub