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

**jo_2010** · بالامس في 06:37

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

بعد التحية

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

**Foksh** · بالامس في 09:07

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

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

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** · بالامس في 10:24

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

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

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

JO_2.accdb

تم تعديل بالامس في 11:05 بواسطه jo_2010

**Foksh** · بالامس في 11:37

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

**jo_2010** · بالامس في 11:46

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

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

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

JO_2.accdb

**Foksh** · بالامس في 12:12

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

**kkhalifa1960** · بالامس في 17:29

أولا استاذ @Foksh عمرة مقبولة وعقبل الحج الاكبر انشاء الله . :fff:

اسمحولى بالمشاركة بهذا المرفق . تفضل استاذ @jo_2010 محاولتي حسب مافهمت اليك المرفق . :fff:

Jo_ExportToExcel.rar

**Foksh** · بالامس في 17:52

23 دقائق مضت, kkhalifa1960 said:

أولا استاذ @Foksh عمرة مقبولة وعقبل الحج الاكبر انشاء الله .

جزاك الله خيراً أستاذنا الغالي .. ونسأل الله أن يرزقكم زيارة بيته معتمرين وحاجّين إن شاء الله :wub:

**jo_2010** · منذ 13 ساعات

في 19‏/1‏/2026 at 04:12, Foksh 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 75.79 kB · 1 download

معلمى الفاضل خالص الشكر لتعب حضرتك فى تلبية طلبى ولكنى لم اجد اجماليات

اريد كل الاجماليات

23 ساعات مضت, kkhalifa1960 said:

أولا استاذ @Foksh عمرة مقبولة وعقبل الحج الاكبر انشاء الله .

اسمحولى بالمشاركة بهذا المرفق . تفضل استاذ @jo_2010 محاولتي حسب مافهمت اليك المرفق .

Jo_ExportToExcel.rar 91.57 kB · 3 downloads

معلمى الفاضل kkhalifa1960

خالص الشكر على الابداع

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

**Foksh** · منذ 8 ساعات

**kkhalifa1960** · منذ 1 ساعه

استاذ @jo_2010 لو حابب ثبات صف الاسماء عند النزول لاسفل بملف الاكسل كما بالعرض . اليك المرفق . :fff:

Jo_ExportToExcel-1.rar

تسجيل الدخول

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

الردود الموصى بها

jo_2010

Foksh

jo_2010

Foksh

jo_2010

Foksh

kkhalifa1960

Foksh

jo_2010

Foksh

kkhalifa1960

انشئ حساب جديد او قم بتسجيل دخولك لتتمكن من اضافه تعليق جديد

انشئ حساب جديد

تسجيل دخول

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information