Excel Insert

[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 για να περάσει τις εγγραφές?

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