تنسيق البيانات فى جدول الوورد

[mahmoud nasr alhasany]

السلام عليكم ورحمة الله وبركاتة

اريد مساعدتى

اريد تنسيق البيانات فى جدول الوورد كما هو موضح فى صورة

ملف تصدير.xlsm

[محمد هشام.]

وعليكم السلام ورحمة الله نعالى وبركاته 

يمكنك الإعتماد على ورقة مخفية ضمن المصنف لترحيل البيانات المطلوبة إليها وحفظها مباشرة  بصيغة Word 

 

Option Explicit
Private Const DocName As String = "التوكيلات"
Private Const FolderName As String = "ملفات Word"
Sub ExportToWord()
    Dim CrWS As Worksheet, dest As Worksheet, a As Variant, b As Variant
    Dim lastRow As Long, i As Long, savePath As String, xPath As String
    Dim wdApp As Object, wdDoc As Object, tbl As Object, d As Object, OnRng As Range

    Application.ScreenUpdating = False
    Set CrWS = Sheets("صلاحيات رواكد"): Set dest = Sheets("WordCopy"): Set d = CreateObject("Scripting.Dictionary")
    dest.Visible = xlSheetVisible

    a = CrWS.Range("A1:H" & CrWS.Cells(Rows.Count, 1).End(xlUp).Row).Value
    dest.Range("A1:E" & dest.Rows.Count).ClearContents

    For i = LBound(a) To UBound(a): d(i) = Array(a(i, 1), a(i, 3), a(i, 4), a(i, 6), a(i, 8)): Next i
    b = Application.Transpose(Application.Transpose(d.items)): dest.Range("A1").Resize(UBound(b), UBound(b, 2)) = b
    
    lastRow = dest.Cells(dest.Rows.Count, 1).End(xlUp).Row
    Set OnRng = dest.Range("A1:E" & lastRow)
    With OnRng
        .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter
    End With

    Set wdApp = CreateObject("Word.Application"): wdApp.Visible = True: Set wdDoc = wdApp.Documents.Add
    wdDoc.PageSetup.Orientation = 1: OnRng.Copy: wdDoc.Content.Paste: Set tbl = wdDoc.Tables(1)
    
    With tbl: .Range.ParagraphFormat.Alignment = 1: .Borders.Enable = True
        Dim ColArr As Variant: ColArr = Array(110, 110, 250, 110, 110)
        For i = 0 To UBound(ColArr): .Columns(i + 1).PreferredWidth = ColArr(i): Next i
    End With

    With tbl.Rows.Add
        .Cells(4).Range.Text = ": المجموع": .Cells(5).Range.Text = Application.Sum(dest.Range("E2:E" & lastRow))
        With .Cells(4).Range: .Font.Color = RGB(255, 0, 0): .ParagraphFormat.Alignment = 1: End With
        .Cells(5).Range.Font.Color = RGB(255, 0, 0): .Cells(5).Range.Font.Bold = True
        .Cells(1).Merge tbl.Rows(tbl.Rows.Count).Cells(4)
    End With

    xPath = ThisWorkbook.Path & "\" & FolderName
    If Dir(xPath, vbDirectory) = "" Then MkDir xPath
    savePath = xPath & "\" & DocName & ".docx"
    
    On Error Resume Next
    wdDoc.SaveAs savePath
    If Err.Number <> 0 Then
        MsgBox "الملف مفتوح بالفعل حاول إغلاقه والمحاولة مرة أخرى ", vbCritical
        wdDoc.Close False: wdApp.Quit: Set wdDoc = Nothing: Set wdApp = Nothing
        Exit Sub
    End If
    On Error GoTo 0
    
    wdDoc.Close False: wdApp.Quit: Set wdDoc = Nothing: Set wdApp = Nothing
    dest.Visible = xlSheetVeryHidden: Set dest = Nothing
    Application.ScreenUpdating = True
    MsgBox "تم تصدير البيانات بنجاح"
End Sub

 

 

 

ملف تصدير V2.xlsm

[mahmoud nasr alhasany]

الف شكر استاذنا / محمد هشام  هذا هو المطلوب

هل يمكن اضافة \تنسيق الأرقام فى كود الصنف على ورقة الوورد بحيث تظهر دائمًا بخمسة أرقام مع إضافة أصفار في البداية إذا لزم الأمر (مثل 00245، 02458، 231456)

لقد فعلت هذا الخيار ولم يفلح الامر

For i = LBound(a) To UBound(a)
        ' تعديل هنا: تحويل الرقم إلى نص ثم تنسيقه
        d(i) = Array(a(i, 1), Format(CStr(a(i, 3)), "00000"), a(i, 4), a(i, 6), a(i, 8))
    Next i

 

تم تعديل السبت at 20:51 بواسطه mahmoud nasr alhasany

[محمد هشام.]

هل تقصد هدا 

 

التوكيلات.docx

 

ملف تصدير V3.xlsm

تم تعديل السبت at 22:51 بواسطه محمد هشام.

[mahmoud nasr alhasany]

ممتاذا ا / محمد هشام هل يمكن جعل البيانات فى الوورد بالطول وليس بالعرض رجاء حتى ولو تم تصغير حجم الخط ليتطلب ذلك نظرا لان طباعة البيانات كثيرة وسيتطلب وورق اكثر

تم تعديل الأحد at 07:59 بواسطه mahmoud nasr alhasany

[محمد هشام.]

نعم أخي فقط قم بتعديل السطور التالية  

 With tbl
        .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
        .Rows.Alignment = wdAlignRowCenter
        .Borders.Enable = True
         Dim ColArr As Variant: ColArr = Array(80, 80, 200, 80, 80)
         For i = 0 To UBound(ColArr)
            .Columns(i + 1).PreferredWidth = ColArr(i)
        Next i
  End With

تم  تعديل الكود على الملف المرفق  مع إظافة إمكانية حفظ الملف بصيغة PDF عند الحاجة 

 

 

ملف تصدير V4.xlsm

تم تعديل الأحد at 15:26 بواسطه محمد هشام.

[mahmoud nasr alhasany]

الف شكر لك ا / محمد هشام

هذا هو المطلوب عمله