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

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

السلامةعليكم ورحمة الله وبركاته. اساتذتي ممكن كود في زر الامر في نموذج 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