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

**jo_2010** · يوليو 18

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

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

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

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

تم تعديل يوليو 18 بواسطه jo_2010

**Foksh** · يوليو 18

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

    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

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

تم تعديل يوليو 18 بواسطه Foksh
تصحيح خطأ إملائي ..

**jo_2010** · يوليو 20

في 18‏/7‏/2026 at 16:06, Foksh said:
أخي جو ..
الجزء المسؤول عن ضبط وتنسيق العناوين يقع كما هو واضح في الكود الذي شاركته ، داخل الجزء التالي :-
    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
على العموم جرب ، وأخبرنا بالنتيجة ..

استاذى ومعلمى الخبير الفاضل Foksh

خالص الشكر لحضرتك زادك اللة خبرة وعلم

الف شكر

تم تعديل يوليو 20 بواسطه jo_2010

تسجيل الدخول

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

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

jo_2010

Foksh

jo_2010

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

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

تسجيل دخول

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

تصفح الموقع

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

Support

Important Information