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

[jo_2010]

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

هذا الكود ابتكرة الخبير الفاضل خليفة اعادة الله الى المنتدى بالف سلامة

Private Sub EXCEL_Click()

 
    Dim folderPath As String
    Dim FilePath As String
    Dim FileName As String
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlWS As Object
    Dim LastRow As Long
    Dim lastCol As Long
    Dim NewRow As Long
    Dim C As Long

    ' التأكد من اختيار الشهر والسنة
    If Len(Me.MS_YR & "") = 0 Then
        MsgBox "الرجاء اختيار الشهر والسنة أولاً", vbExclamation + vbMsgBoxRight, "تنبيه"
        Me.MS_YR.SetFocus
        Exit Sub
    End If

    ' إنشاء فولدر حفظ النسخ بجوار القاعدة
    folderPath = CurrentProject.Path & "\Jo_Excel"
    If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath

    ' اسم الملف مع التاريخ والوقت
    FileName = "اجمالى شــهر _" & Replace(Me.MS_YR.Value, "/", "-")     ' "_" & Format(Now, "yyyy-mm-dd_HH-MM-ss") & ".xlsx"
    FilePath = folderPath & "\" & FileName

    ' تصدير الاستعلام
    On Error Resume Next
    DoCmd.TransferSpreadsheet _
        acExport, _
        acSpreadsheetTypeExcel12Xml, _
        "Q_Total_Company_Excel", _
        FilePath, _
        True
    If Err.Number <> 0 Then
        MsgBox "خطأ عند التصدير: " & Err.Description
        Exit Sub
    End If
    On Error GoTo 0

    ' فتح Excel للتنسيق
    Set xlApp = CreateObject("Excel.Application")
    Set xlWB = xlApp.Workbooks.Open(FilePath)
    Set xlWS = xlWB.Sheets(1)
    xlApp.Visible = True

    ' آخر صف وعمود
    LastRow = xlWS.Cells(xlWS.Rows.count, 1).End(-4162).Row   ' xlUp
    lastCol = xlWS.Cells(1, xlWS.Columns.count).End(-4159).Column ' xlToLeft

    ' ==============================
    ' تثبيت الصف الأول بدون Select
    ' ==============================
    xlWS.Application.ActiveWindow.SplitRow = 1
    xlWS.Application.ActiveWindow.FreezePanes = True

    ' ==============================
    ' حدود لجميع الخلايا
    ' ==============================
    With xlWS.Range(xlWS.Cells(1, 1), xlWS.Cells(LastRow, lastCol)).Borders
        .LineStyle = 1
        .Weight = 2
    End With

    ' تنسيق العناوين
    With xlWS.Range(xlWS.Cells(1, 1), xlWS.Cells(1, lastCol))
        .Interior.Color = RGB(52, 152, 219)
        .Font.Color = RGB(255, 255, 255)
        .Font.Bold = True
        .HorizontalAlignment = -4108
        .VerticalAlignment = -4108
    End With

    ' ==============================
    ' إضافة صف الإجماليات أسفل البيانات
    ' ==============================
    NewRow = LastRow + 1

    ' دمج أول 4 أعمدة وكتابة "الإجمالي"
    With xlWS.Range(xlWS.Cells(NewRow, 1), xlWS.Cells(NewRow, 4))
        .Merge
        .Value = "الإجمالي"
        .Font.Bold = True
        .HorizontalAlignment = -4108
        .VerticalAlignment = -4108
    End With

    ' جمع الأعمدة من الخامس فصاعدًا
    For C = 5 To lastCol
        xlWS.Cells(NewRow, C).Formula = _
            "=SUM(" & xlWS.Cells(2, C).Address & ":" & xlWS.Cells(LastRow, C).Address & ")"
    Next C

    ' تنسيق صف الإجمالي
    With xlWS.Range(xlWS.Cells(NewRow, 1), xlWS.Cells(NewRow, lastCol))
        .Font.Bold = True
        .Font.Size = 12
        .Interior.Color = RGB(255, 255, 0)

        ' حدود خارجية سميكة
        With .Borders(7)   ' Left
            .LineStyle = 1
            .Weight = 4
        End With
        With .Borders(10)  ' Right
            .LineStyle = 1
            .Weight = 4
        End With
        With .Borders(8)   ' Top
            .LineStyle = 1
            .Weight = 4
        End With
        With .Borders(9)   ' Bottom
            .LineStyle = 1
            .Weight = 4
        End With

        ' حدود داخلية أخف
        With .Borders(11)  ' Inside Vertical
            .LineStyle = 1
            .Weight = 2
        End With
        With .Borders(12)  ' Inside Horizontal
            .LineStyle = 1
            .Weight = 2
        End With
    End With

    xlWS.Columns.AutoFit

    xlWB.save
    xlWB.Close
    xlApp.Quit

    Set xlWS = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing

     MsgBox "JO_Excel" & "  " & " تـم التصدير ... بنجاح مع حفظ النسخة في فولدر ", vbInformation + vbMsgBoxRight

 
End Sub

اريد العمود الاول الذى يتحتوى اسماء الشركات ان يكون راسيا  كما بالصورة 2

بدل من افقيا كما  بالصورة 1

هل هذا ممكن ام لالا

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