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

إلغاء الدمج والتعبئة


gorh
إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

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

جرب هذا الكود

Option Explicit
Sub Unmerg_cells()
If ActiveSheet.Name <> "ورقة1" Then Exit Sub
Dim lr#, i#
Dim My_rg As Range, x, y, z, n
Dim My_min
lr = Cells(Rows.Count, "D").End(3).Row

For i = 2 To lr
    If Cells(i, 2).MergeCells Then
     x = Cells(i, 1)
     y = Cells(i, 2)
     z = Cells(i, 3)
     n = Cells(i, 2).MergeArea.Rows.Count
     Cells(i, 1).UnMerge
     Cells(i, 1).Resize(n) = x
     
     Cells(i, 2).UnMerge
     Cells(i, 2).Resize(n) = y
     
     Cells(i, 3).UnMerge
     Cells(i, 3).Resize(n) = z
     
     My_min = Application.Min(Range("d" & i).Resize(n))
     Range("d" & i).Resize(n) = Format(My_min, "d/m/yyy")
     i = i + n - 1
    End If
 Next
End Sub

الملف مرفق

 

Gorh.xlsm

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

استاذ سليم 
أسأل الله أن يوفقك جــزاك الله كل خير 
الكود رائع جدا جدا 
ملاحظه بسيطه 
اذا كانت القيم ضمن خلية واحدة وليست مدمجة 
انظر الملف المرفق
 

DATA2.xlsx

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

  • أفضل إجابة

و هذا ملف يمكنك منه خلاله الاختيار دمج الخلايا  او  عدم دمجها 

زر لكل اختيار (على 3 أعمدة (يمكن الاضافة قدر ما تريد)

Option Explicit
Sub Unmerg_cells()
Application.ScreenUpdating = False
If ActiveSheet.Name <> "Test" Then GoTo End_Me
Dim lr#, i#
Dim My_rg As Range, x, y, z, n
Dim My_min
lr = Cells(Rows.Count, "A").End(3).Row

For i = 2 To lr
    If Cells(i, 1).MergeCells Then
     x = Cells(i, 1)
     y = Cells(i, 2)
     z = Cells(i, 3)
     n = Cells(i, 1).MergeArea.Rows.Count
     Cells(i, 1).UnMerge
     Cells(i, 1).Resize(n) = x
     
     Cells(i, 2).UnMerge
     Cells(i, 2).Resize(n) = y
     
     Cells(i, 3).UnMerge
     Cells(i, 3).Resize(n) = z
     i = i + n - 1
    End If
 Next
End_Me:
 Range("A1").Select
 Application.ScreenUpdating = True
End Sub
'++++++++++++++++++
Sub merge_all()
Application.ScreenUpdating = False
If ActiveSheet.Name <> "Test" Then GoTo End_Me
 Dim k%
  For k = 1 To 3
    Call One_for_all(k)
  Next
   With Range("A1").CurrentRegion
   .Font.Size = 14
   .Font.Bold = True
   End With
End_Me:
  Range("A1").Select
  Application.ScreenUpdating = True
End Sub
'+++++++++++++++++++++++++++++++++++++

Sub One_for_all(ByVal Col As Integer)
Application.DisplayAlerts = False
Dim i%, lr%, My_rg As Range
Dim x
lr = Cells(Rows.Count, Col).End(3).Row
Set My_rg = Cells(1, Col)
 For i = 1 To lr
      x = Cells(i, Col).Value
    If My_rg.Cells(1).Value = x Then
       Set My_rg = Union(My_rg, Cells(i, Col))
      My_rg.MergeCells = True
    Else
      Set My_rg = Cells(i, Col)
    End If
 Next
Application.DisplayAlerts = True
End Sub

الملف مرفق

 

 

Merge_Unmerge_rows_Multiple_colmns.xlsm

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

  • 1 month later...

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