[Tasos]

Καλημέρα Θάνο!

Δοκίμασε τον παρακάτω κώδικα.

Δεν έχω την δυνατότητα να τον δοκιμάσω αφού δεν έχω την αντίστοιχη βάση δεδομένων.

Αν υπάρξει κάποιο πρόβλημα θα πρέπει να μας ανεβάσεις όπως είχαμε πει και ένα παράδειγμα της βάσης σου.

Private Sub btnExcelExport_Click()
    Dim rs As DAO.Recordset
    Dim rsCount As Long
    Dim i As Integer
    Dim rHeight As Single
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim rngTotalRow As Range
    Dim MySheetPath As String
    Dim MySQL As String
    xlWB.Windows(1).Visible = True
    MySQL = "SELECT PreorderDetails.PreorderDetailDescription,Preorder .approvaltext1, "
    MySQL = MySQL & "Preorder.Approved,PreorderDetails.Price,Preorderde tails.quantity, "
    MySQL = MySQL & "Preorderdetails.UOM FROM Preorder INNER JOIN PreorderDetails "
    MySQL = MySQL & "ON Preorder.PreorderID = PreorderDetails.PreorderID WHERE "
    MySQL = MySQL & "Preorder.PreorderID =" & Me!PreorderID & " AND Preorder.Approved=true"

    Set rs = CurrentDb.OpenRecordset(MySQL, dbOpenSnapshot)

    MySheetPath = "E:\ACCESS DATABASE\sxedio2.xls"

    If rs.RecordCount Then
        rs.MoveLast
        rs.MoveFirst
        rsCount = rs.RecordCount

        On Error GoTo ExitHere
        Set xlApp = CreateObject("Excel.Application")
        xlApp.Visible = True
        Set xlWB = xlApp.Workbooks.Open(MySheetPath)
        xlWB.Windows(1).Visible = True
        Set wks = xlWB.Worksheets(1)

        wks.Range("C10") = Nz(rs!approvaltext1, "")
        Set rngTotalRow = wks.Range("A20:K20")
        If rsCount > 4 Then
            With rngTotalRow
                rHeight = .RowHeight
                For i = 1 To rsCount - 4
                    .Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    .Offset(-1).RowHeight = rHeight
                    .Offset(-2).AutoFill Destination:=wks.Range(.Offset(-2), .Offset(-1)), Type:=xlFillFormats
                    .RowHeight = rHeight
                Next
            End With
        End If
        i = 16
        While Not rs.EOF
            wks.Range("C" & i) = Nz(rs!PreorderDetailDescription, "")
            If rs!UOM = "temaxia" Then
                wks.Range("D" & i) = Nz(rs!Quantity, 0)
            Else
                wks.Range("E" & i) = Nz(rs!Quantity, 0)
            End If
            wks.Range("H" & i) = Nz(rs!Price, 0)
            rs.MoveNext
        Wend
ExitHere:
        If Err <> 0 Then
            MsgBox "Σφάλμα: " & Err & vbLf & Err.Description, vbExclamation
        End If
        rs.Close
        Set rs = Nothing
        Set xlApp = Nothing
    End If
End Sub

Με εκτίμηση

Τάσος