تصدير عدة استعلامات الى اكسيل واحد

[فؤاد الدلوي]

السلامةعليكم ورحمة الله وبركاته. اساتذتي ممكن كود في زر الامر في نموذج A لتصدير اربعة استعلامات في قاعدة البيانات الى اوراق عمل في اكسيل واحد مع جزيل الشكر.

test.accdb

[Foksh]

6 ساعات مضت, فؤاد الدلوي said:

السلامةعليكم ورحمة الله وبركاته. اساتذتي ممكن كود في زر الامر في نموذج A لتصدير اربعة استعلامات في قاعدة البيانات الى اوراق عمل في اكسيل واحد مع جزيل الشكر.

test.accdb 556 kB · 5 downloads

تفضل فكرتي المتواضعة ، حيث سيتم أولاً تحميل أسماء الاستعلامات في الليست بوكس ، وانت تختار ما تريده ، ثم انقر الزر للتصدير :-

Private Sub Export_Selected_Queries()
    Dim xlApp As Object, xlWorkbook As Object, xlWorksheet As Object
    Dim db As DAO.Database, rs As DAO.Recordset
    Dim sheetIndex As Integer, colIndex As Integer, rowIndex As Integer
    Dim filePath As String, queryName As String
    Dim i As Variant

    filePath = Application.CurrentProject.Path & "\تقرير_الاكسيل.xlsx"

    If Me.Que_List.ItemsSelected.Count = 0 Then
        MsgBox "يرجى تحديد استعلام واحد على الأقل قبل التصدير", vbExclamation + vbMsgBoxRight, "خطأ"
        Exit Sub
    End If

    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    Set xlWorkbook = xlApp.Workbooks.Add

    Set db = CurrentDb
    sheetIndex = 1

    For Each i In Me.Que_List.ItemsSelected
        queryName = Trim(Me.Que_List.ItemData(i))

        Set rs = db.OpenRecordset(queryName, dbOpenSnapshot)
        
        If sheetIndex <= xlWorkbook.Sheets.Count Then
            Set xlWorksheet = xlWorkbook.Sheets(sheetIndex)
        Else
            Set xlWorksheet = xlWorkbook.Sheets.Add
        End If
        
        xlWorksheet.Name = queryName
        
        colIndex = 1
        With xlWorksheet
            For Each fld In rs.Fields
                .Cells(1, colIndex).Value = fld.Name
                .Cells(1, colIndex).Font.Bold = True
                colIndex = colIndex + 1
            Next fld

            rowIndex = 2
            Do While Not rs.EOF
                colIndex = 1
                For Each fld In rs.Fields
                    .Cells(rowIndex, colIndex).Value = fld.Value
                    colIndex = colIndex + 1
                Next fld
                rowIndex = rowIndex + 1
                rs.MoveNext
            Loop
        End With

        rs.Close
        sheetIndex = sheetIndex + 1
    Next i

    xlWorkbook.SaveAs filePath
    xlWorkbook.Close
    xlApp.Quit

    On Error Resume Next
    Set rs = Nothing
    Set db = Nothing
    Set xlWorksheet = Nothing
    Set xlWorkbook = Nothing
    Set xlApp = Nothing
    On Error GoTo 0

    MsgBox "تم تصدير البيانات بنجاح", vbInformation + vbMsgBoxRight, "نجاح العملية"
End Sub

 

test.accdb

 

 

[فؤاد الدلوي]

استاذي العزيز @Foksh العمل اكثر من رائع شكرا جزيلاً طلب اخر استاذ كيف اجمع الاستعلامات الاربعة في استعلام واحد في قاعدة البيانات بحيث تظهر كافة السجلات على اعتبار ان الاستعلام الرئيسي هو qallshm2 

تم تعديل فبراير 26 بواسطه فؤاد الدلوي

[Foksh]

12 ساعات مضت, فؤاد الدلوي said:

على اعتبار ان الاستعلام الرئيسي هو qallshm2

هل هذا ما تقصده ؟؟

SELECT TIP.*, 
       TSHM.*, 
       TSHY.[id] AS TSHY_id, TSHY.*, 
       Ttipr.[id] AS Ttipr_id, Ttipr.*, 
       Tmsr.[id] AS Tmsr_id, Tmsr.[No], Tmsr.[اسم المادة], 
       Tmsr.[مبلغ الصرف], Tmsr.data, Tmsr.Year
FROM ((((TIP 
LEFT JOIN TSHM ON TIP.id = TSHM.[id])
LEFT JOIN TSHY ON TIP.id = TSHY.[id])
LEFT JOIN Ttipr ON TIP.id = Ttipr.[id])
LEFT JOIN Tmsr ON TIP.id = Tmsr.[id]);

 

[فؤاد الدلوي]

استاذ @Foksh جزاك الله تعالى كل خير وهو المطلوب شكراً جزيلاً

[فؤاد الدلوي]

استاذ @Foksh وأذا اردت تحديد الاستعلامات فقط بهذه الاربعة بدون اختيار من مربع القائمة اي بمجرد الضغط على زر الامر يتم التصدير الى اكسيل ويحفظ الملف بالوقت والناريخ الحالي شكرا

test.accdb

[Foksh]

منذ ساعه, فؤاد الدلوي said:

استاذ @Foksh وأذا اردت تحديد الاستعلامات فقط بهذه الاربعة بدون اختيار من مربع القائمة اي بمجرد الضغط على زر الامر يتم التصدير الى اكسيل ويحفظ الملف بالوقت والناريخ الحالي شكرا

test.accdb 624 kB · 1 download

في هذه الحالة ، سنقوم باستعمال مصفوفة بسيطة على سبيل المثال لتحديد الإستعلامات التي موجودة لديك ، كالتالي :-

Sub ExportQueriesToExcel()
    Dim xlApp As Object
    Dim xlWorkbook As Object
    Dim xlWorksheet As Object
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim queryNames As Variant
    Dim sheetIndex As Integer
    Dim filePath As String
    Dim colIndex As Integer
    Dim rowIndex As Integer
    
    queryNames = Array("Qallmsr2", "Qallshm2", "Qallshy2", "Qalltipr2")
    
    filePath = Application.CurrentProject.Path & "\تقرير_الاكسيل.xlsx"
    
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True

    Set xlWorkbook = xlApp.Workbooks.Add

    Set db = CurrentDb
    sheetIndex = 1
    
    For Each queryName In queryNames
        Set rs = db.OpenRecordset(queryName, dbOpenSnapshot)
        
        If sheetIndex <= xlWorkbook.Sheets.Count Then
            Set xlWorksheet = xlWorkbook.Sheets(sheetIndex)
        Else
            Set xlWorksheet = xlWorkbook.Sheets.Add
        End If
        
        xlWorksheet.Name = queryName
        
        colIndex = 1
        For Each fld In rs.Fields
            xlWorksheet.Cells(1, colIndex).Value = fld.Name
            xlWorksheet.Cells(1, colIndex).Font.Bold = True
            colIndex = colIndex + 1
        Next fld

        rowIndex = 2
        Do While Not rs.EOF
            colIndex = 1
            For Each fld In rs.Fields
                xlWorksheet.Cells(rowIndex, colIndex).Value = fld.Value
                colIndex = colIndex + 1
            Next fld
            rowIndex = rowIndex + 1
            rs.MoveNext
        Loop
        
        rs.Close
        
        sheetIndex = sheetIndex + 1
    Next queryName

    xlWorkbook.SaveAs filePath
    xlWorkbook.Close
    xlApp.Quit
    
    Set rs = Nothing
    Set db = Nothing
    Set xlWorksheet = Nothing
    Set xlWorkbook = Nothing
    Set xlApp = Nothing
    
    MsgBox "تم تصدير البيانات بنجاح", vbInformation + vbMsgBoxRight, "نجاح العملية"
End Sub

 

test.accdb

[فؤاد الدلوي]

استاذ @Foksh شكراً استاذ وهو المطلوب