Excel Insert

[thanosgr]

Καλημέρα εχω ενα πρόβλημα..
θέλω να κανω εισαγωγή κελιών μεσα απο την access σε ενα αρχειο excel.
Εχω ενα προτυπο αρχειο, με κελια με εγγραφες που τραβαει απο την Access

το αρχειο ειναι φτιαγμενο για 4 περιπου εγγραφες. και θέλω εάν ειναι παραπάνω απο 4 για να μην μου χαλάει το κείμενο που εχω κατω απο τα κελιά με τις εγγραφες να κανει insert.

το προβλημα ειναι οτι περναει τις εγγραφε΄ς στα υπολοιπα κελιά, αλλα πηδάει τα κελια που εχω απλως ενα κείμενο. Ουσιαστικά θελω το κειμενο να κανει shiftdown και εαν ειναι δυνατο να κραταει και το format των προηγούμενων κελιων.


Private Sub btnExcelExport_Click()

'We'll start by creating a recordset named rstexcel.
Dim rstexcel As DAO.Recordset
Dim lngCount, lnginsert As Long

'Build the SQL statement (swiped from a query).
Dim MySQL As String


MySQL = "SELECT PreorderDetails.PreorderDetailDescription,Preorder .approvaltext1, Preorder.Approved,PreorderDetails.Price,Preorderde tails.quantity, Preorderdetails.uom"
MySQL = MySQL & " FROM Preorder INNER JOIN PreorderDetails ON Preorder.PreorderID = PreorderDetails.PreorderID "
MySQL = MySQL & " WHERE Preorder.PreorderID =" & Me!PreorderID & " and preorder.approved=true"



Set rstexcel = CurrentDb.OpenRecordset(MySQL, dbOpenForwardOnly)


'Now rstexcel contains records to be exported.

'Now for the Excel rigmarole.
'Define the path to the workbook, save it as MySheetPath.
Dim MySheetPath As String
'Note: You must change the path and filename below
'to an actual Excel .xlsx file on your own computer.
MySheetPath = "E:\ACCESS DATABASE\sxedio2.xls"

'Set up object variables to refer to Excel and objects.
Dim Xl As Excel.Application
Dim XlBook As Excel.Workbook
Dim XlSheet As Excel.Worksheet

'Open an instance of Excel, open the workbook.
Set Xl = CreateObject("Excel.Application")
Set XlBook = GetObject(MySheetPath)

'Make sure everything is visible on the screen.
Xl.Visible = True
XlBook.Windows(1).Visible = True

'Define the topmost sheet in the Workbook as XLSheet,
Set XlSheet = XlBook.Worksheets(1)
lngCount = 16
lnginsert = 20
With rstexcel
XlSheet.Range("c10") = rstexcel("approvaltext1")
Do Until .EOF
If rstexcel.RecordCount > 4 Then

XlSheet.Range("A" & lnginsert).Insert (xlShiftDown)
lnginsert = lnginsert + 1
End If

XlSheet.Range("C" & lngCount) = rstexcel("PreorderDetailDescription")

If rstexcel!UOM = "temaxia" Then
XlSheet.Range("D" & lngCount) = rstexcel("Quantity")
Else
XlSheet.Range("E" & lngCount) = rstexcel("Quantity")
End If

XlSheet.Range("H" & lngCount) = rstexcel("Price")
.MoveNext

Loop

End With

'Clean up and end with worksheet visible on the screen.
rstexcel.Close
Set rstexcel = Nothing

Set Xl = Nothing
Set XlBook = Nothing
Set XlSheet = Nothing


End Sub


Ευχαριστώ

[Tasos]

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

Ο κώδικας όπως παρουσιάζεται έχει κάποια λαθάκια αλλά δεν θα πρέπει να σε απασχολεί αφού υπάρχει πιο απλή λύση χρησιμοποιώντας τη μέθοδο εισαγωγής δεδομένων Access στην Excel από την επιφάνεια εργασίας του Excel.

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

Με εκτίμηση

Τάσος

[thanosgr]

Οκ ευχαριστώ ανέβασα το αρχείο

Ναι έχει κάποια λαθάκια
κατω απο το .movenext
lngCount=lngCount+1

ξεχασα να βάλω τον μετρηρή. Πάντως για τις πρώτες 4 εγγραφές δουλεύει. Θέλω με το που φτάνει στο σύνολο να προσθέτει τα κελιά και να εισάγει τις επόμενες εγγραφές. Αυτο που κάνει τώρα ειναι ,εισάγει τις νέες εγγραφες όπου βρίσκει υπάρχον κείμενο, το παρακάμπτει, και γράφει στα επόμενα κελια, πχ τεχνικες προδιαγραφές

Ευχαριστώ

ΥΣ:Τον κώδικα τον βρήκα απο βιβλίο αλλα δεν ειχε σχετικά με το insert παρα μόνο απο το help της VBA αλλα δεν ειχε καλό παράδειγμα

[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

Με εκτίμηση

Τάσος

[thanosgr]

Τάσο Ευχαριστώ
rHeight = .RowHeight
method or data member not found.

[thanosgr]

Οκ το διόρθωσα το πρόβλημα βλεπω εκτελεί αλλά δεν μου ανοίγει το excel

[Tasos]

Θάνο δεν με βοηθάς καθόλου.

Θα έπρεπε να ανεβάσεις ένα αρχείο Access για να βλέπουμε τι κάνουμε και να μην δίνουμε άστοχες απαντήσεις.

Μπορείς να δοκιμάσεις τον τροποποιημένο κώδικα στο προηγούμενο μήνυμα μου.

Τάσος

[thanosgr]

Τάσο ευχαριστώ
δουλεύει, απλως ηθελε να βάλω xl as excel.applcation και να το κάνω visible μπροστά στα μάτια μου ήτανε :)

Ευχαριστώ

[Tasos]

Να είσαι καλά Θάνο!

Καλή συνέχεια!

[thanosgr]

Γειά σου Τάσο εκανα κατι αλλαγές στο excel αρχειο, δουλευει αλλα πάνω απο τις 10 εγγραφές που το έχω βάλει μου κάνεi De-Merge τα κελιά
Θέλει κάποια αλλαγή στον κωδικα αλλα δεν γνωρίζω

Dim rs As DAO.Recordset
Dim rsCount As Long
Dim i, icount As Integer
'Dim rHeight As single
Dim xl As Excel.Application
Dim xlWB As Excel.Workbook
Dim wks As Excel.Worksheet
'Dim rngTotalRow As Single'
Dim MySheetPath As String
Dim MySQL As String

MySQL = "SELECT Preorder.numberid,Preorder.preorderdate,PreorderDe tails.PreorderDetailDescription,Preorder.approvalt ext1, "
MySQL = MySQL & "PreorderDetails.Price,Preorderdetails.quantit y, "

'MySQL = MySQL & "Preorder.Approved,PreorderDetails.Price,Preorderd etails.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:\PREORDERS\sxediofinal.xls"

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

On Error GoTo ExitHere
Set xl = CreateObject("Excel.Application")
Set xlWB = GetObject(MySheetPath)

xlWB.Windows(1).Visible = True
xl.Visible = True

Set wks = xlWB.Worksheets(1)
wks.Range("Q2") = Nz(rs!NumberID, "")
wks.Range("Q5") = Nz(rs!ApprovalText1, "")
wks.Range("Q1") = Nz(rs!PreorderDate, "")
Set rngTotalRow = wks.Range("D14:D23")
If rsCount > 10 Then
With rngTotalRow
rheight = .RowHeight
For i = 1 To rsCount - 10
.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 = 14
icount = 1
While Not rs.EOF
wks.Range("A" & i) = icount
wks.Range("D" & i) = Nz(rs!PreorderDetailDescription, "")
If rs!UOM = "ôåì" Then
wks.Range("J" & i) = Nz(rs!Quantity, 0)
Else
wks.Range("I" & i) = Nz(rs!Quantity, 0)
End If
wks.Range("M" & i) = Nz(rs!Price, 0)
rs.MoveNext
i = i + 1
icount = icount + 1
Wend
ExitHere:
If Err <> 0 Then
MsgBox "ËÜèïò: " & Err & vbLf & Err.Description, vbExclamation
End If
rs.Close
Set rs = Nothing
If Not xlWB Is Nothing Then Set xlWB = Nothing
End If

End Sub

Αυτο είναι βασισμένο στον δικό σου κώδικα

2) Μπορείς να δείς γιατί δεν μου ανοίγει αυτόματα το Excel? αλλα θα πρέπει να γίνει χειροκίνητα το άνοιγμα του Excel για να περάσει τις εγγραφές?

Ευχαριστώ
Θάνος