نسخة من التواريخ

[فوزى فوزى]

السلام عليكم ورحمة الله وبركاته تحية طيبة ممكن عمل كود يدمج الخلايا على معلومية أيام الشهر شهر 5 يبداء من يوم 27 وينتهى يوم  31  يدمج الخلايا التي بها الشهور وهى D4:H4 وهذا ينطبق على كل الشهور واذا غيرنا اليوم من الخليه A2 باى قيمية 15 تتغير القيمة فى ايام الشهر يدمج الخلايا من 15 الى اخر يوم فى الشهر وهذا موضح فى الشيت

نسخة من التواريخ.xlsm

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

تصحيح المعادلات في الصف الخامس (ضروري)

جرب هذا الكود

Option Explicit
Sub MERGE_CELLS()
 Dim RG As Range
 Dim i%, x%
 Application.ScreenUpdating = False
 x = Cells(5, Columns.Count).End(1).Column
 Application.DisplayAlerts = False
    With Range("d4").Resize(, x)
    .UnMerge
    .Value = vbNullString
    .Borders.LineStyle = 1
    End With
  Application.DisplayAlerts = True
 Set RG = Cells(4, 4)
 For i = 4 To x

    If Month(Cells(5, i)) = Month(Cells(5, i + 1)) Then
     Set RG = Union(RG, RG.Offset(, 1))
     RG.Merge
     Else
     Set RG = Cells(4, i + 1)
    End If
             RG = "  شهر:" & Month(Cells(5, i))
     Next
   Cells(4, x + 1).Resize(50, 20).Clear
    Application.ScreenUpdating = True
End Sub
'+++++++++++++++
Sub Unmge()
 Dim x%
 x = Cells(5, Columns.Count).End(1).Column
 Application.DisplayAlerts = False
    With Range("d4").Resize(, x)
    .UnMerge
    .Value = vbNullString
    .Borders.LineStyle = 1
    End With
  Application.DisplayAlerts = True
End Sub

الملف مرفق

Merge_Fouzy.xlsm

[فوزى فوزى]

استاذ سليم ممكن بعد الدمج تكون حدود الخلية كما فى الصورة

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

استبدل في هذا السطر الرقم 1 بـــ  xlNo

 .Borders.LineStyle = 1

 

 

 

[فوزى فوزى]

قمت بالاستبدال فاعطتنى هكذا

والمفروض تكون هكذا

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

ارجع    Borders.LineStyle = xlNo     الى 1    

أضف الى الكود هذا السطر في المكان المناسب (حسب الصورة)

 

 

[فوزى فوزى]

لك مني كل الحب والتقدير شكرا من القلب  استاذ سليم

استاذ سليم انا اسف على تعب سيادتكم معى نفطة اخرى

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

لا أعلم بالضبط اذا كان هذا المطلوب

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 Application.EnableEvents = False
 Dim RG As Range
 Dim i%, x%, lr%
 lr = Cells(Rows.Count, 1).End(3).Row
 If lr < 6 Then lr = 12
  x = Cells(5, Columns.Count).End(1).Column
  Range("d5").Resize(lr - 1, x - 3).Interior.ColorIndex = xlNone

 Set RG = Range("d5").Resize(, x - 3)
  If Not Intersect(Target, RG) Is Nothing And Target.Count = 1 Then
   Target.Resize(lr - 1).Interior.ColorIndex = 6
  End If
  Application.EnableEvents = True
End Sub
'+++++++++++++++++++++++++++++++
Sub MERGE_CELLS()
 Dim RG As Range
 Dim i%, x%, t%, lr%
 Application.ScreenUpdating = False
 Unmge
 lr = Cells(Rows.Count, 1).End(3).Row
 If lr < 6 Then lr = 12
 x = Cells(5, Columns.Count).End(1).Column
 Cells(4, 4).Resize(lr, x).Borders.LineStyle = 1
 Set RG = Cells(4, 4)
 For i = 4 To x

    If Month(Cells(5, i)) = Month(Cells(5, i + 1)) Then
     Set RG = Union(RG, RG.Offset(, 1))
     RG.Merge
    Else
     Set RG = Cells(4, i + 1)
    End If
       RG = "  شهر:" & Month(Cells(5, i))
     Next
   Cells(4, x + 1).Resize(lr, 20).Clear
   For i = 4 To x
    If Cells(4, i).MergeCells Then
    t = Cells(4, i).MergeArea.Columns.Count
    Cells(4, i).Resize(lr, t).BorderAround 1, 3
    i = i + t - 1
    End If
   Next
   Cells(4, 4).Resize(, x - 3).BorderAround 1, 3
    Application.ScreenUpdating = True
End Sub
'+++++++++++++++
Sub Unmge()
 Dim x%, Ro%
 Ro = Cells(Rows.Count, 1).End(3).Row
 If Ro < 6 Then Ro = 12
 x = Cells(5, Columns.Count).End(1).Column
 
 Application.DisplayAlerts = False
    With Range("d4").Resize(Ro, x)
    .UnMerge
    .Rows(1) = vbNullString
    .Borders.LineStyle = 1
    End With
  Application.DisplayAlerts = True
End Sub

الملف مرفق من جديد

 

New_merge_Fouzi.xlsm

[فوزى فوزى]

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

انت رائع استاذ سليم عند العمل على الشت جعلنى انبهر من اداءك وتحقيق المطلوب