تعديل على تصدير بيانات من اكسس الى اكسل

أتمنى من الاخوان الإفادة ،،، للضرورة

تحياتي

تفضل الكود المعدل :)

Option Compare Database
Option Explicit

Private Sub CmdExport_Click()
Dim TheFile As String
Dim lngColumn As Long
Dim xlx As Object, xlw As Object, xls As Object, xlc As Object
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim blnEXCEL As Boolean, blnHeaderRow As Boolean
Dim Counter As Integer

blnEXCEL = False
blnHeaderRow = False
On Error Resume Next
Set xlx = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set xlx = CreateObject("Excel.Application")
blnEXCEL = True
End If
Err.Clear
On Error GoTo 0
xlx.Visible = True
TheFile = CurrentProject.Path & "\Tables.xlt"
Set xlw = xlx.Workbooks.Open(TheFile)
Set xls = xlw.Worksheets("sheet1")
Set xlc = xls.Range("B14")
xls.Range("a2") = [txtcode]

Set dbs = CurrentDb()
'Set rst = dbs.OpenRecordset("s_names", dbOpenDynaset)
Set rst = Me.stu_F.Form.RecordsetClone

rst.MoveLast: rst.MoveFirst
If rst.EOF = False And rst.BOF = False Then
rst.MoveFirst

If blnHeaderRow = True Then
For lngColumn = 0 To rst.Fields.Count - 1

xlc.Offset(0, lngColumn).Value = rst.Fields(lngColumn).Value

Next lngColumn
Set xlc = xlc.Offset(1, 0)
End If

Counter = 0
Do While rst.EOF = False
Counter = Counter + 1

For lngColumn = 0 To rst.Fields.Count - 1
''rst.Edit
'rst!datasheat = rst!elem_name & HyperlinkPart(rst.Fields("datasheat"), acAddress)
''rst.Update
xlc.Offset(0, lngColumn).Value = rst.Fields(lngColumn).Value

Next lngColumn
rst.MoveNext

If Counter = 25 Then Set xlc = xls.Range("B62")
Set xlc = xlc.Offset(1, 0)
Loop
End If

rst.Close
Set rst = Nothing
dbs.Close
Set dbs = Nothing
Set xlc = Nothing
Set xls = Nothing
xlw.Close True
Set xlw = Nothing
If blnEXCEL = True Then xlx.Quit
Set xlx = Nothing
End Sub

جعفر

احسنت اخي الكريم جعفر ،،،

عمل رائع

+1

حياك الله :)