اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


bachiri401
إذهب إلى أفضل إجابة Solved by الـعيدروس,

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

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

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

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

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

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

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

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

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

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

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

 

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

  • أفضل إجابة

جرب هذا الكود

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

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

 

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

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

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

 

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

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

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

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

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

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

 

 

 

تم تعديل بواسطه الـعيدروس
  • Thanks 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