كود ترحيل الخلايا الممتلئة مكان الفارغة

[osama elmorsy]

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

mr-salim-code.xlsm

[سليم حاصبيا]

الخلايا المدمجة داخل الجدول (العدو الأول للأكواد والمعادلات )   تجنب استعمالها

اذا كان لا بد منها يجب عزلها عن بقية الجدول بصف فارغ(يمكن اخفاءه)

في الصورة مثلاً  الخلية  A127 مدموجة مع الخلبة B127

  الخلية  A128 مدموجة مع الخلبة B128 و هكذا  حتى A136..    ونفس الشيء  من  A37 الى A46  /  من  A82 الى A91  

 

 الكود المطلوب بعد ازالة دمج الخلايا (الصفحة Salim  من هذا الملف)

Option Explicit

Sub del_data()
    Dim Ar(), ar_Num()
    Dim Rg_To_copy, cel As Range
    Dim My_sh As Worksheet
    Dim Dic As Object
    Dim y%, k%

    Set My_sh = Sheets("Salim")
    Set Dic = CreateObject("Scripting.Dictionary")

 Ar = Array("B5", "B37", "B50", "B82", "B95", "B127")
 ar_Num = Array(30, 10, 30, 10, 30, 10)

For k = LBound(Ar) To UBound(Ar)

     For Each cel In My_sh.Range(Ar(k)).Resize(ar_Num(k))
         If Not IsEmpty(cel) Then
       Rg_To_copy = My_sh.Range("B" & cel.Row).Resize(, 7)
       Rg_To_copy = Application.Transpose(Rg_To_copy)
       Rg_To_copy = Application.Transpose(Rg_To_copy)
       Dic(Dic.Count) = Join(Rg_To_copy, "*")
      End If
     Next
  
      If Dic.Count Then
       My_sh.Range(Ar(k)).Resize(ar_Num(k), 7).ClearContents
        For y = 0 To Dic.Count - 1
         My_sh.Range(Ar(k)).Offset(y).Resize(, 7).Value = _
         Split(Dic.Item(y), "*")
        Next
       End If
     Dic.RemoveAll
 Next k
   
    Set Rg_To_copy = Nothing: Set cel = Nothing
    Set My_sh = Nothing: Set Dic = Nothing
    Erase Ar: Erase ar_Num
    
End Sub

الملف مرفق

salim-coding.xlsm

[osama elmorsy]

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