Private Function ADOVersion()
    Dim cn As New ADODB.Connection
    Set cn = New ADODB.Connection
    ADOVersion = cn.Version
End Function

If Not (.BOF And .EOF) Then  ' czy są rekordy (krotki, br...)

If Not (.BOF And .BOF) Then

Option Explicit

Public Sub WriteIntoExcel(ByVal sPathFileXls As String)
    On Error GoTo WriteIntoExcel_Error

    Dim Cn As ADODB.Connection
    Dim Rst As ADODB.Recordset
    Dim strQuery As String
    Dim i As Long
    Dim bEmptyRec As Boolean
    Dim FieldsList As Variant
    Dim FieldsValues As Variant
    Dim varBookmark As Variant

    FieldsList = Array(0, 1, 2, 3)
    FieldsValues = Array("wpis1", "wpis2", "wpis3", CStr(Time))

    Set Cn = New ADODB.Connection
    With Cn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .ConnectionString = "Data Source=" & sPathFileXls & _
                            ";Extended Properties=""Excel 8.0;HDR=YES"";"
        .Open
    End With

    strQuery = "SELECT pole1,pole2,pole3,pole4 FROM [Arkusz1$]"     ' "SELECT * FROM [Arkusz1$]"
    Set Rst = New ADODB.Recordset
    With Rst
        .CursorLocation = adUseServer
        .CursorType = adOpenKeyset
        .LockType = adLockOptimistic
        .Open strQuery, Cn
        ' na clonie mozna tez szukac i bookmark na bookmark
        If Not (.BOF And .EOF) Then ' poprawione po uwadze Wojtka w poscie powzej
            .MoveLast
            Do While Not .BOF
                bEmptyRec = True
                For i = 0 To .Fields.Count - 1
                    If Len(Trim(.Fields(i).Value & "")) <> 0 Then
                        bEmptyRec = False
                        Exit For
                    End If
                Next
                If bEmptyRec = False Then Exit Do
                varBookmark = .Bookmark
                .MovePrevious
            Loop
        End If
        i = 0
        ' przypusmy chce dodac 4-ry rekordy
        Dim lNewNumber As Long
        lNewNumber = 4
        If Not IsEmpty(varBookmark) Then
            .Bookmark = varBookmark
            Do While Not .EOF And i < lNewNumber
                .Update FieldsList, FieldsValues
                i = i + 1
                MsgBox "Update " & CStr(i)
                .MoveNext
            Loop
        End If
        Do While i < lNewNumber
            .AddNew FieldsList, FieldsValues
            i = i + 1
            MsgBox "Addnew " & CStr(i)
        Loop
        ' w przypadku gdy tylko 1-den rekord dodajesz wystarczy
        ' If Not IsEmpty(varBookmark) Then
        ' .Bookmark = varBookmark
        ' .Update FieldsList, FieldsValues
        ' Else
        ' .AddNew FieldsList, FieldsValues
        ' End If

    End With
    ' poniższe niepotrzebne tylko do testowania
    Call TestListRS(objRs:=Rst, objWrk:=ThisWorkbook.Worksheets("test"))

WriteIntoExcel_Exit:
    On Error Resume Next
    If Not Rst Is Nothing Then
        With Rst
            If .State = adStateOpen Then .Close
        End With
        Set Rst = Nothing
    End If
    If Not Cn Is Nothing Then
        With Cn
            If .State = adStateOpen Then .Close
        End With
        Set Cn = Nothing
    End If
    Exit Sub

WriteIntoExcel_Error:
    MsgBox "Błąd : ( " & Err.Number & " ) " & Err.Description & vbCrLf & _
           "Procedura : " & "WriteIntoExcel", vbExclamation
    Resume WriteIntoExcel_Exit
End Sub

Public Sub TestListRS(objRs As ADODB.Recordset, objWrk As Worksheet)
' niepotrzebne tylko do testowania
Dim i As Long
Dim j As Long

    With objWrk
        .Activate
        .Cells.Clear
    End With
    j = 1
    With objRs
        For i = 0 To .Fields.Count - 1
            objWrk.Cells(1, i + 2) = .Fields(i).Name & " : " & .Fields(i).DefinedSize
        Next
        If Not (.BOF And .BOF) Then
            .MoveFirst
            Do While Not .EOF
                j = j + 1
                objWrk.Cells(j, 1) = j - 1
                For i = 0 To .Fields.Count - 1
                    objWrk.Cells(j, i + 2) = .Fields(i).Value & ""
                Next
                .MoveNext
            Loop
        End If
    End With
End Sub

Public Sub WriteIntoExcel()
    Dim cn As ADODB.Connection, rst As New ADODB.Recordset, strQuery As String _
    FieldsList As Variant, FieldsValues As Variant
    
    FieldsList = Array(0, 1, 2, 3)
    FieldsValues = Array("wpis1", "wpis2", "wpis3", "wpis4")
    
    Set cn = New ADODB.Connection

    With cn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .ConnectionString = "Data Source=C:\new.xls;" & _
                            "Extended Properties=Excel 8.0;"
        .Open
    End With

    strQuery = "SELECT * FROM [Arkusz1$]"

    rst.Open strQuery, cn, adOpenDynamic, adLockOptimistic

    With rst
        .AddNew FieldsList, FieldsValues
        .Update
    End With

    rst.Close
    Set rst = Nothing

End Sub