اذهب الي المحتوي
أوفيسنا

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


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

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

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

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

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

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

حذف صف عن طريق الماكرو.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

 

تم تعديل بواسطه شحادة بشير
  • Like 1
رابط هذا التعليق
شارك

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

جدًا رائع،،

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

  • Like 1
رابط هذا التعليق
شارك

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

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

 

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

  • Like 1
رابط هذا التعليق
شارك

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

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

 

  • Like 1
رابط هذا التعليق
شارك

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

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

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

  • Like 1
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • المتواجدين الان   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information