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

[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

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

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

[Foksh]

أخي جو ..
الجزء المسؤول عن ضبط وتنسيق العناوين يقع كما هو واضح في الكود الذي شاركته ، داخل الجزء التالي :-

    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

يعني رح نعدل الجزء ونقسمه على 3 مراحل ، لأنه في طلبك انت تريد بعض العناوين بالشكل الطول والباقي سيبقى كما هو في أصله .. لذا جرب ما يلي ، كونك لم ترفق ملف للتجربة وضمان تأكيد الخطوة .

فقط استبدل الجزء السابق بالجزي التالي :-

' تنسيق العناوين
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

With xlWS.Range(xlWS.Cells(1, 6), xlWS.Cells(1, lastCol))
    .Orientation = 90 'هنا طبعاً زاوية دوران النص ، وتعدلها زل ما بتحب
    .WrapText = True
End With

' وهنا لتحديد ارتفاع الصف الأول حسب أطول عنوان
Dim MaxLen As Long
Dim TxtLen As Long
Dim i As Long

For i = 6 To lastCol
    TxtLen = Len(CStr(xlWS.Cells(1, i).Value))
    If TxtLen > MaxLen Then MaxLen = TxtLen
Next i

xlWS.Rows(1).RowHeight = MaxLen * 6 + 10

 

على العموم جرب ، وأخبرنا بالنتيجة ..