تصدير تقرير الى اكسل

تفضل اخى العزيز هذا مثال من الممكن ان يفيدك 

زر أمر تحويل البيانات الى ملف اكسيل .rar

مشكور اخى على الرد ولكن

تلاحظ عند فح ملف الاكسل بعد تصدير البيانات انه اسماء الحقول و أن اسماء الحقول باللغة العربية

ماذا الحل إذا

كانت اسماء الحقول لاللغة الانجليزية و عناوين الحقول اللغة العربية

شكرا اخى الزميل الفاضل

برجاء مراجعة الملف مرة اخرى و فى انتظار رد قريب من سيادتكم مع جزيل الشكر

وعليكم السلام :)

وبعد إذن اخي ابوجمانه ، فقد اضفت على مثاله :)

لتوضيح ما اضعه بين يديك:

الاوامر لتصدير البيانات من اكسس الى اكسل ، تأخذ اسم الحقول من الجدول ،

وهنا اضع مثالين في كيفية تصدير البيانات ، باستخدام مسميات الحقول الموجودة في الجدول ، وان لم توجد تسميات ، فالكود يأخذ اسم الحقول.

1. النموذج اصبح به زرين جدد ،

2. غيرت حقلين في الجدول ، م صارت ID (وادخلت م كتسمية للحقل ID) ، التاريخ صار iDate (وادخلت التاريخ كتسمية للحقل iDate) ،

3. والنتيجة ، (لاحظ المسميات في الرقم 2 و 3 ، اصبحت ما تريده انت) ،

4. وهذا كود 1:

Private Sub CmdTrans_Click()
Dim strPath As String
strPath = Application.CurrentProject.Path & "\"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Table1", strPath & "Bank", True
End Sub

وهذا كود 2:

Private Sub cmd__with_Fields_Cation_Names_Click()
On Error GoTo err_cmd_Excel_Click



    Dim rst As DAO.Recordset
    Dim fld As Field

    File_Path = Application.CurrentProject.Path & "\Bank2.csv"
    
    Open File_Path For Output As #1
    
'    S = ";"
    S = ","
    Set rst = Me.RecordsetClone

    'field names
    For Each fld In rst.Fields
        iField_Caption = fld.Properties("Caption")
        F = F & S & iField_Caption
    Next
    
    F = Mid(F, 2)
    Print #1, F
    
    rst.MoveFirst
    'field values
    For i = 1 To rst.RecordCount
        F = ""
        For Each fld In rst.Fields
            F = F & S & fld.Value
        Next
        
        F = Mid(F, 2)
        Print #1, F

        rst.MoveNext
    Next i
    
    Close #1
    

Exit Sub
err_cmd_Excel_Click:

    If Err.Number = 3270 Then
        iField_Caption = fld.Name
        Resume Next
    Else
        MsgBox Err.Number & vbCrLf & Err.Description
    End If
    
End Sub

وهذا كود 3:

Private Sub cmd_AccessToXLS_Click()
On Error GoTo err_cmd_AccessToXLS_Click

    Dim objXLApp As Object  'Excel.Application
    Dim xlrngCell As Object 'Excel.Range
    Dim intF As Integer
    Dim rst As DAO.Recordset
    Dim File_Path As String
    
    'Set rst = CurrentDb.OpenRecordset("Select * From Table1")
    Set rst = Me.RecordsetClone
    File_Path = Application.CurrentProject.Path & "\Bank2.xls"
    
    
    Set objXLApp = CreateObject("Excel.Application")
    objXLApp.Visible = False    'True
    
    'wait for the workbook to open
    DoEvents
  
    Set xlrngCell = objXLApp.Workbooks.Add.Worksheets(1).Range("A1")
    For intF = 0 To rst.Fields.Count - 1
        xlrngCell(, intF + 1) = rst.Fields(intF).Properties("Caption")
    Next intF
    
    rst.MoveFirst
    xlrngCell.Offset(1).CopyFromRecordset rst
    
    xlrngCell.Worksheet.Cells.EntireColumn.AutoFit
    xlrngCell.Worksheet.Parent.Saved = True
    

    objXLApp.ActiveWorkbook.SaveAs FileName:=File_Path, FileFormat:=56  'save as a 97-2003 file format
    
    objXLApp.Quit
    
    rst.Close: Set rst = Nothing
    Set objXLApp = Nothing



Exit Sub
err_cmd_AccessToXLS_Click:

    If Err.Number = 3270 Then
        'iField_Caption = fld.Name
        xlrngCell(, intF + 1) = rst.Fields(intF).Name
        Resume Next
    Else
        MsgBox Err.Number & vbCrLf & Err.Description
    End If
    
    
End Sub

جعفر

216.za-AMIR-UP.mdb.zip