RsetToRset

Function MakeRS(ByVal rsSource As ADODB.Recordset) As ADODB.Recordset
    Dim rsTemp As ADODB.Recordset, F As ADODB.Field
    Set rsTemp = New ADODB.Recordset
    For Each F In rsSource.Fields
        If F.Type <> adChapter Then
            rsTemp.Fields.Append F.Name, F.Type, _
                F.DefinedSize, F.Attributes And adFldIsNullable
            With rsTemp(F.Name)
                .Precision = F.Precision
                .NumericScale = F.NumericScale
            End With
        End If
    Next F
    Set MakeRS = rsTemp
End Function
'________________________________________________________

Sub OpenAndFillRS(ByVal rsSource As ADODB.Recordset, ByVal rsDest As ADODB.Recordset)
    Dim F As ADODB.Field
    If rsSource.State = adStateClosed Then Exit Sub<BR/>
    If rsSource.EOF And rsSource.BOF Then Exit Sub
    If rsSource.CursorType <> adOpenForwardOnly Then
        If Not rsSource.EOF And Not rsSource.BOF Then
            rsSource.MoveFirst
        End If
    End If
    rsDest.CursorLocation = adUseClient
    rsDest.Open
    
    Do While Not rsSource.EOF
        rsDest.AddNew
        For Each F In rsSource.Fields
            If F.Type <> adChapter Then rsDest(F.Name).Value = F.Value
        Next F
        rsDest.Update
        rsSource.MoveNext
    Loop
End Sub

Option Explicit
Private Sub Command1_Click()
Dim cn As ADODB.Connection, rsSource As ADODB.Recordset, rsDest As ADODB.Recordset
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=nwind.mdb"
Set rsSource = cn.Execute("SELECT * FROM Customers")
Set rsDest = MakeRS(rsSource)
OpenAndFillRS rsSource, rsDest
rsSource.Close
cn.Close
Set DataGrid1.DataSource = rsDest
End Sub
'________________________________________________________

Function MakeRS(ByVal rsSource As ADODB.Recordset) As ADODB.Recordset
Dim rsTemp As ADODB.Recordset, F As ADODB.Field
Set rsTemp = New ADODB.Recordset
For Each F In rsSource.Fields
If F.Type <> adChapter Then
rsTemp.Fields.Append F.Name, F.Type, _
F.DefinedSize, F.Attributes And adFldIsNullable
With rsTemp(F.Name)
.Precision = F.Precision
.NumericScale = F.NumericScale
End With
End If
Next F
Set MakeRS = rsTemp
End Function
'________________________________________________________

Sub OpenAndFillRS(ByVal rsSource As ADODB.Recordset, ByVal rsDest As ADODB.Recordset)
Dim F As ADODB.Field
If rsSource.State = adStateClosed Then Exit Sub<BR/>
If rsSource.EOF And rsSource.BOF Then Exit Sub
If rsSource.CursorType <> adOpenForwardOnly Then
If Not rsSource.EOF And Not rsSource.BOF Then
rsSource.MoveFirst
End If
End If
rsDest.CursorLocation = adUseClient
rsDest.Open

Do While Not rsSource.EOF
rsDest.AddNew
For Each F In rsSource.Fields
If F.Type <> adChapter Then rsDest(F.Name).Value = F.Value
Next F
rsDest.Update
rsSource.MoveNext
Loop
End Sub