إلغاء دمج الخلايا آليا

[bachiri401]

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

هناك مثال توضيحي داخل الملف المرفق

توقيت الافسام.xlsx

[Ali Mohamed Ali]

وعليكم السلام-فقط عليك استخدام هذا الكود

Sub UnmergeAllCells()
ActiveSheet.Cells.UnMerge
End Sub

 

[bachiri401]

بارك الله فيك اخي

لكني اريد بعد عملية الغاء الدمج واعادة كتابة البيانات في الخلية الثانية نفسها الاولى كما في المثال وليس تركها فارغة 

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

بعد اذن الاخ علي

جرب هذا الماكرو

Sub UnMergeRange()
    Dim i%, k%, ro%, col%
    Dim MY_RG As Range, CEL As Range
ro = Cells(Rows.Count, 1).End(3).Row
col = Cells(2, Columns.Count).End(1).Column
Set MY_RG = Range("A3").Resize(ro - 2, col)

MY_RG.UnMerge
 For Each CEL In MY_RG
  If CEL = vbNullString Then _
  CEL = CEL.Offset(, -1)
 Next
MY_RG.Columns.AutoFit
Set MY_RG = Nothing: Set CEL = Nothing
End Sub

 

[bachiri401]

بارك الله فيك اخي الكود يعمل  لكن يقوم بملء الخلايا الفارغة اصلا بالبيانات من الخلية التي قبلها

[الـعيدروس]

جرب هذا الكود

بعد اذن الاساتذه الافاضل

Dim Ar()
Dim i
Private Sub Merg_Ali()
Dim C As Range
Dim A As String
Dim B
Sp False
Erase Ar: i = 0
For Each C In ActiveSheet.UsedRange.Cells
If C.MergeCells Then
If i >= 1 Then
If Ar(1, i) = C.MergeArea.Address Then GoTo nx
End If
i = i + 1
ReDim Preserve Ar(1 To 2, 1 To i)
A = C.MergeArea.Address: B = C.Value
Ar(1, i) = A: Ar(2, i) = B
nx:
C.UnMerge
End If
Next
Sp True
If i Then Ar = Application.Transpose(Ar)
End Sub
Private Sub Ad(A)
Sp False
For x = LBound(A, 1) To UBound(A, 1)
    Range(A(x, 1)) = A(x, 2)
Next
Sp True
End Sub
Sub Ali_Mr()
Merg_Ali
If i Then Ad Ar: Erase Ar: i = 0
End Sub
Private Function Sp(Bl As Boolean)
With Application
    .ScreenUpdating = Bl
    .EnableEvents = Bl
End With
End Function

 

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

ما هو انت الذي طلبت ذلك من خلال هذه العبارة في سؤالك:

يتم فك الادماج واعادة كتابة البيانات في الخلية الثانية بحيث لا تترك فارغة 

 

[bachiri401]

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

الكود يعمل 100 ب 100

[الـعيدروس]

ولك مثل دعائك اضعاف اخ بشير

او بالامكان عبر الكود التالي اخف من السابق

بحيث الحلقة تمشي فقط على الخلايا الفارغة في نطاق البيانات

والتي تعتبر افتراضيا فيها دمج

Sub Ali_Merg()
Dim C_Rng As Object
Dim A, B
Application.ScreenUpdating = False
For Each C_Rng In Application.ActiveSheet.Cells.SpecialCells(xlCellTypeBlanks)
    With C_Rng
        If .MergeCells Then
        A = .MergeArea.Address: B = .Value
            .UnMerge: Range(A).Value = B
        End If
    End With
Next
Application.ScreenUpdating = True
End Sub

 

 

 

تم تعديل نوفمبر 28, 2019 بواسطه الـعيدروس

[bachiri401]

ربي يزيدك من فضله وعلمه ويحفضك من كل شر وبلية