طلب كود أو ماكرو لحذف صف العنوان من كل جدول ودمج الفارغ من الخلايا

[حامل المسك]

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

وفقكم الله يا كرام،،

لدي ملف وورد به العديد من الجداول أريد ماكرو أو كود لحذف صف العنوان من كل جدول،،

وكذلك دمج خانة الاسم مع خانة العمل في حال كان العمل فارغا،،

مرفق المثال،،

حذف صف عن طريق الماكرو.docx

[شحادة بشير]

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

آمين وإياكم

أولاً: ما كرو حذف الترويسة من الجدول:

Sub DeleteHeader()
Dim Tbl As Table
If ActiveDocument.Tables.Count > 0 Then
   For Each Tbl In ActiveDocument.Tables
       Tbl.Rows(1).Delete
   Next
   MsgBox ("تمت عملية حذف ترويسة الجدول لكل الجداول في المستند الحالي")
Else
   MsgBox ("لا يوجد ضمن المستند الحالي أي جدول")
End If
End Sub

 

ثانياً: ماكرو فحص خانة العمل الفارغة ودمجها بخانة الاسم:

Sub MergeCell()
ActiveDocument.DeleteAllEditableRanges (-1)
Dim Tbl As Table
If ActiveDocument.Tables.Count > 0 Then
   For Each Tbl In ActiveDocument.Tables
       For i = 1 To Tbl.Rows.Count
          If Len(Tbl.Cell(i, 3).Range.Text) < 3 Then
          'إذا كان طول الخلية أقل من 3 محارف فهذا يعني أنها فارغة
             'بدء عملية الدمج
             Set Rng = Tbl.Cell(i, 2).Range
             Rng.End = Tbl.Cell(i, 3).Range.End
             Rng.Cells.Merge
          End If
       Next
   Next
   MsgBox ("تمت عملية فحص خلايا عمود العمل الفارغة وإجراء ما يلزم من الدمج")
Else
   MsgBox ("لا يوجد ضمن المستند الحالي أي جدول")
End If
End Sub

 

تم تعديل أكتوبر 14, 2021 بواسطه شحادة بشير

[حامل المسك]

ما شاء الله تبارك الله ،، إبدااااااع يا مبدع،،

جدًا رائع،،

طلب أخير نلاحظ بعد الدمج يجعل  الضبط على التوسيط هل بالإمكان أن يكون على ضبط تباعد صغير

[شحادة بشير]

قمت بإضافة السطر التالي المتعلق بضبط الحقل تباعد صغير:

Tbl.Cell(i, 3).Range.ParagraphFormat.Alignment = wdAlignParagraphJustifyLow

 

وهذا هو الكود كاملاً:

Sub MergeCell()
ActiveDocument.DeleteAllEditableRanges (-1)
Dim Tbl As Table
If ActiveDocument.Tables.Count > 0 Then
   For Each Tbl In ActiveDocument.Tables
       For i = 1 To Tbl.Rows.Count
          If Len(Tbl.Cell(i, 3).Range.Text) < 3 Then
          'إذا كان طول الخلية أقل من 3 محارف فهذا يعني أنها فارغة
             'ضبط الحقل تباعد صغير
             Tbl.Cell(i, 3).Range.ParagraphFormat.Alignment = wdAlignParagraphJustifyLow
             'بدء عملية الدمج
             Set Rng = Tbl.Cell(i, 2).Range
             Rng.End = Tbl.Cell(i, 3).Range.End
             Rng.Cells.Merge
          End If
       Next
   Next
   MsgBox ("تمت عملية فحص خلايا عمود العمل الفارغة وإجراء ما يلزم من الدمج")
Else
   MsgBox ("لا يوجد ضمن المستند الحالي أي جدول")
End If
End Sub

 

لا تنساني من دعواتك الطيبة المباركة

[حامل المسك]

كلمة الإبداع قليلة،،

لك صادق الدعوات في هذا اليوم المبارك،،

بارك الله لك في أهلك ومالك وولد وفرج همك وغمك،،

سلمت كتب الله أجرك

[حامل المسك]

أسعدك الله يا غالي،،

بالنسبة لكود الدمج في حال وجود صف سبق دمجه،،

تأتي هذه الرسالة

فهل بالإمكان تخطي الصف المدموج والعمل على البقية

[شحادة بشير]

الحل السريع وضع كود تجاوز الأخطاء أولاً:

On Error Resume Next

بحيث يصبح الكود في النهاية هكذا:

Sub MergeCell()
On Error Resume Next

ActiveDocument.DeleteAllEditableRanges (-1)
Dim Tbl As Table
If ActiveDocument.Tables.Count > 0 Then
   For Each Tbl In ActiveDocument.Tables
       For i = 1 To Tbl.Rows.Count
          If Len(Tbl.Cell(i, 3).Range.Text) < 3 Then
          'إذا كان طول الخلية أقل من 3 محارف فهذا يعني أنها فارغة
             'ضبط الحقل تباعد صغير
             Tbl.Cell(i, 3).Range.ParagraphFormat.Alignment = wdAlignParagraphJustifyLow
             'بدء عملية الدمج
             Set Rng = Tbl.Cell(i, 2).Range
             Rng.End = Tbl.Cell(i, 3).Range.End
             Rng.Cells.Merge
          End If
       Next
   Next
   MsgBox ("تمت عملية فحص خلايا عمود العمل الفارغة وإجراء ما يلزم من الدمج")
Else
   MsgBox ("لا يوجد ضمن المستند الحالي أي جدول")
End If
End Sub

 

[حامل المسك]

أسعدك الله في هذه الساعات المباركات، وسلمك وأغناك ومن كل سوء حماك،،

روعة الرد أنك تعدل على نفس المثال، وتسهل الوصول للمعلومة..

سهل الله لك كل عسير،،