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

[jo_2010]

الخبراء الافاضل

بعد التحية

مارايدة موجود بالصورة هل هذا ممكن ام شئ صعب

JO.accdb

[Foksh]

وعليكم السلام أخي يوسف ..

تفضل ملفك بعد التعديل ، حيث تم استخدام الحدث التالي في الزر :-

Private Sub أمر0_Click()
    On Error GoTo ErrorHandler
    
    Dim db As DAO.Database
    Dim qdf As DAO.QueryDef
    Dim strSQL As String
    Dim strFileName As String
    Dim strFilePath As String
    Dim strQueryName As String
    
    strSQL = "SELECT Tcode, Tname, Out_Lab, IN_Lab, Total, IN_Staff, Total_Staff FROM (" & _
             "  SELECT 0 AS SortID, Tcode, Tname, Out_Lab, IN_Lab, Total, IN_Staff, Total_Staff FROM Tbl_Tests " & _
             "  UNION ALL " & _
             "  SELECT 1 AS SortID, '', 'المجموع الكلي', SUM(Out_Lab), SUM(IN_Lab), SUM(Total), SUM(IN_Staff), SUM(Total_Staff) FROM Tbl_Tests" & _
             ") " & _
             "ORDER BY SortID, Val(Tcode), Tcode;"
    
    strFileName = Format(Now, "yyyy-mm-dd_hh-nn-ss") & ".xlsx"
    strFilePath = CurrentProject.Path & "\" & strFileName
    
    strQueryName = "TempExportQuery"
    Set db = CurrentDb
    
    On Error Resume Next
    db.QueryDefs.Delete strQueryName
    On Error GoTo ErrorHandler
    
    Set qdf = db.CreateQueryDef(strQueryName, strSQL)
    
    DoCmd.OutputTo acOutputQuery, strQueryName, acFormatXLSX, strFilePath, False
    
    db.QueryDefs.Delete strQueryName
    
    MsgBox "تم تصدير البيانات بنجاح", vbInformation + vbMsgBoxRight, "تم التصدير"
    
ExitProcedure:
    Set qdf = Nothing
    Set db = Nothing
    Exit Sub

ErrorHandler:
    MsgBox "حدث خطأ أثناء عملية التصدير", vbCritical + vbMsgBoxRight, "خطأ"
    Resume ExitProcedure
End Sub

 

وسيتم انشاء ملف اكسل باسم = الوقت الحالي وتاريخ اليوم ، وتستطيع تغيير اسم الملف كما تريد .

JO.zip

[jo_2010]

شكر  خاص للخبير الفاضل Foksh

حاولت اطبق كود حضرتك على الاستعلام الحقيقى ولكتة لايعمل

ممكن المساعدة ادرجت النموذج والاتعلام الحقيقى اعتذز لما حدث

JO_2.accdb

تم تعديل منذ 2 ساعات بواسطه jo_2010

[Foksh]

قم برفع الملف مرة أخرى اذا سمحت .. مع العلم انه والمفروض ارفاق الملف الذي ستعمل عليه ، وليس ملف مختلف عن ارض الواقع .

[jo_2010]

10 ساعات مضت, Foksh said:

قم برفع الملف مرة أخرى اذا سمحت .. مع العلم انه والمفروض ارفاق الملف الذي ستعمل عليه ، وليس ملف مختلف عن ارض الواقع .

انا اسف لما حدث ولن يتكرر مرة اخرى

JO_2.accdb

[Foksh]

30 دقائق مضت, jo_2010 said:

انا اسف لما حدث ولن يتكرر مرة اخرى

لا عليك .. تفضل ملفك بعد التعديل باستخدام الحدث التالي :-

Private Sub EXCEL_Click()
    On Error GoTo ErrorHandler
    
    Dim db As DAO.Database
    Dim qdf As DAO.QueryDef
    Dim rs As DAO.Recordset
    Dim strSQL As String
    Dim strFileName As String
    Dim strFilePath As String
    Dim strQueryName As String
    Dim strTempTable As String
    Dim strMonthYear As String
    
    If IsNull(Me.MS_YR) Or Me.MS_YR = "" Then
        MsgBox "الرجاء اختيار الشهر والسنة أولاً", vbExclamation + vbMsgBoxRight, ""
        Exit Sub
    End If
    
    strMonthYear = Me.MS_YR
    
    strQueryName = "TempExportQuery"
    strTempTable = "TempExportTable"
    
    Set db = CurrentDb
    
    On Error Resume Next
    DoCmd.DeleteObject acTable, strTempTable
    On Error GoTo ErrorHandler
    
    On Error Resume Next
    db.QueryDefs.Delete strQueryName
    On Error GoTo ErrorHandler
    
    strSQL = "TRANSFORM Count(All_Names.ID) AS CountمنID " & _
             "SELECT All_Names.Ddate, All_Names.Pcode, All_Names.DCode, All_Names.Pname, All_Names.Price " & _
             "FROM ALL_Companys LEFT JOIN All_Names ON ALL_Companys.Name_comp = All_Names.Company " & _
             "WHERE All_Names.Mon_Year = '" & strMonthYear & "' " & _
             "GROUP BY All_Names.ID, All_Names.Ddate, All_Names.Pcode, All_Names.DCode, All_Names.Pname, All_Names.Price " & _
             "PIVOT ALL_Companys.Name_comp In (""ثروة للتامين"",""مصر للتامين"",""دلتا للتامين"",""وثاق"",""ثروة حياة"",""رويال"",""جلوب ميد"",""بنك مصر"",""الحفر المصرية"",""التامين المصري السعودى"",""المصرية للاتصالات"",""بنك الإسكان"",""WE"",""GIG"",""AROPE"",""LIBANO SUISSE"",""QNB"");"
    
    Set qdf = db.CreateQueryDef(strQueryName, strSQL)
    
    DoCmd.RunSQL "SELECT * INTO " & strTempTable & " FROM " & strQueryName
    
'    strFileName = "Export_" & Format(Now, "yyyy-mm-dd_hh-nn-ss") & ".xlsx" 'هنا سيتم حفظ الملف حسب الوقت الحالي مع تاريخ اليوم
    strFileName = Replace(strMonthYear, "/", "-") & ".xlsx" 'هنا سيتم حفظ الملف برقم الشهر والسنة
    
    strFilePath = CurrentProject.Path & "\" & strFileName
    
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, strTempTable, strFilePath, True
    
    DoCmd.DeleteObject acTable, strTempTable
    db.QueryDefs.Delete strQueryName
    
    MsgBox "تم تصدير البيانات بنجاح", vbInformation + vbMsgBoxRight, "تم التصدير"
    
ExitProcedure:
    Set rs = Nothing
    Set qdf = Nothing
    Set db = Nothing
    Exit Sub

ErrorHandler:
    MsgBox "حدث خطأ أثناء عملية التصدير", vbCritical + vbMsgBoxRight, "خطأ"
    
    On Error Resume Next
    If Not db Is Nothing Then
        DoCmd.DeleteObject acTable, strTempTable
        db.QueryDefs.Delete strQueryName
    End If

    Resume ExitProcedure
End Sub

 

ولكن ارجو تحديد الحقول التي تريد الاجماليات لها ، أم جميعها ؟؟

لأنني لم أقم بإضافتها إلا بعد اعتماد الحل أعلاه

 

JO_2.zip