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

أبو عبد الله _ · مايو 1, 2023

السلام عليكم

المطلوب

اولا هو كود لاظهار رسالة تنبيهية في حال زيادة عدد البيانات في العمود C عن ١٠ اشخاص

مع العلم ان البيانات متغييرة في العمود C وليست ثابتة

قمت بكتابة كود لاظهار رسالة في حال زيادة العناصر الثابتة في حدث الورقة لتوضيح الفكرة

ثانيا كود لتلوين الخلايا من C ال F اعتمادا على البيانات المكررة في العمود C بحيث ان كل مجموعة تكرارات تأخذ لون مستقل

countif.xlsm

**محمد هشام.** · مايو 1, 2023

وعليكم السلام ورحمة الله تعالى وبركاته

اخي هل تقصد رسالة تنبيه عند تكرار نفس القيمة 10 مرات او التنبيه بحسب اجمالي القيم المدخلة في العمود

اما بالنسبة للثاني كان من الافضل وضع مثال للمطلوب هل تلوين المجموعات بشرط ان يكون التكرار في عمود c

وبهدا يتم تلوين نفس القيم في النطاق المطلوب ام فقط تلوين المجموعات اينما وجد التكرار

**محمد هشام.** · مايو 1, 2023

بما انك لم تقم بالاجابة سوف احاول وضع جميع الاحتمالات الواردة

بخصوص السؤال الاول يمكنك اختيار ما يناسبك ووضعه في حدث الشيت

''تنبيه عند تكرار نفس القيمة في العمود اكثر من 10 مرات
Private Sub Worksheet_Change(ByVal Target As Range)
    With Target
    ' تحديد رقم العمود الهدف
              If (.Column <> 3) Or .Cells.Count > 10 Then Exit Sub

   ' تحديد اقصى عدد للتكرار المسموح به
        If WorksheetFunction.CountIf(Columns(.Column), .Value) > 10 Then
           'حدف القيمة المدخلة
            .ClearContents
  MsgBox "لايمكن طباعة أكثر من 10", vbMsgBoxRight + vbOKOnly, "لا يمكن الاستمرار"

        End If
    End With
End Sub
'''''''''''''''''''''''''''''

Private Sub Worksheet_Change(ByVal Target As Range)
' تنبيه عند تجاوز عدد القيم  على العمود 10 قيم

Dim ws As Worksheet
Set ws = Sheet1
Dim LastRow As Long
Application.ScreenUpdating = False

     LastRow = ws.Range("C65000").End(xlUp).Row
     DataCount = Application.WorksheetFunction.CountA(ws.Range("C:C"))

  ' تجديد عدد القيم المسموح بها
If DataCount > 10 Then

  MsgBox "لايمكن طباعة أكثر من 10", vbMsgBoxRight + vbOKOnly, "لا يمكن الاستمرار"

            'حدف القيمة المدخلة

ws.Cells(Rows.Count, "c").End(xlUp).ClearContents

        End If
End Sub

اما بخصوص السؤال الثاني

Sub test1()
   ' تلوين المجموعات في النطاق المطلوب اينما وجد التكرار

    ' قم بظبط الاعدادات بما يناسبك
    Const FirstRow      As Long = 2   ' اول صف
    Const FirstColumn   As String = "C"  'اول عمود
    Const LastColumn    As String = "F"   ' اخر عمود

    Dim dict            As Object
    Dim Ky              As Variant
    Dim rng             As Range
    Dim Arr             As Variant
    Dim Rl              As Long
    Dim Cols            As Variant
    Dim Idx             As Long
    Dim Sp()            As String
    Dim c               As Long
    Dim R               As Long

'أضف العديد من الألوان كما يحلو لك
  Cols = Array(65535, 10086143, 16763904, 15123099, 9359529, 11854022, 32896, 65280, 16711680, 65535, 16711935, _
   16763904, 13434828, 16764057, _
  13408767, 16751052, 10079487)

    Application.ScreenUpdating = False
   
    Set dict = CreateObject("Scripting.Dictionary")
    With Worksheets("Sheet1")               '  اسم الورقة الخاص بك
    ' حدف التنسيقات السابقة
         Columns("C:F").Interior.Pattern = xlNone
        For c = Columns(FirstColumn).Column To Columns(LastColumn).Column
            Rl = .Cells(.Rows.Count, c).End(xlUp).Row
            If Rl >= FirstRow Then
                Set rng = .Range(.Cells(1, c), .Cells(Rl, c))
                Arr = rng.Value
                For R = FirstRow To Rl
                    If Len(Arr(R, 1)) Then
                        ' تسجيل عنوان كل خلية غير فارغة حسب القيمة
                        dict(Arr(R, 1)) = dict(Arr(R, 1)) & "," & _
                                               Cells(R, c).Address
                    End If
                Next R
            End If
        Next c

        For Each Ky In dict
            Sp = Split(dict(Ky), ",")
   '  شرط عدد التكرار لتنفيد الامر
    If UBound(Sp) > 1 Then
                
                
                ' تطبيق نفس اللون على نفس القيم
                For c = 1 To UBound(Sp)
                    .Range(Sp(c)).Interior.Color = Cols(Idx)
                Next c
                Idx = Idx + 1
                ' إعادة تدوير الألوان إذا كانت غير كافية
                If Idx > UBound(Cols) Then Idx = LBound(Cols)
            End If
        Next Ky
    End With
    Application.ScreenUpdating = True
End Sub

'''''''''''''''''''''''''''''''''''''''''
'("C") تلوين المجموعات بشرط تكرارها في عمود
Sub test2()
    Dim ws As Worksheet
    Dim cell As Range
    Dim myrng As Range
    Dim clr As Long
    Dim lastCell As Range

    Set ws = ThisWorkbook.Sheets("Sheet1")
    'النطاق الهدف
    Set myrng = ws.Range("c2:f" & Range("c" & ws.Rows.Count).End(xlUp).Row)
    ' نطاق الشرط
    Set myrng2 = ws.Range("c2:c" & Range("c" & ws.Rows.Count).End(xlUp).Row)

    With myrng
        Set lastCell = .Cells(.Cells.Count)
    End With
    myrng.Interior.ColorIndex = xlNone
    clr = 3

    For Each cell In myrng
        If Application.WorksheetFunction.CountIf(myrng2, cell) > 1 Then
            If myrng.Find(what:=cell, lookat:=xlWhole, MatchCase:=False, after:=lastCell).Address = cell.Address Then
                cell.Interior.ColorIndex = clr
                clr = clr + 1
            Else
                cell.Interior.ColorIndex = myrng.Find(what:=cell, lookat:=xlWhole, MatchCase:=False, after:=lastCell).Interior.ColorIndex
            End If
        End If
    Next
End Sub

ولاستخراج القيم وعدد تكرارها يمكنك استخدام الكود التالي

Sub test3()  ' عدد القيم المكررة
 Dim rng As Range
 Dim var As Variant
 Dim i   As Integer
 Dim ws As Worksheet
 Set ws = Sheet1
 lr = Range("C65536").End(xlUp).Row
 Set myrng = ws.Range("M1:N" & Range("c" & ws.Rows.Count).End(xlUp).Row)
    Application.ScreenUpdating = False

myrng.clear
ws.[M1] = "القيم"
ws.[N1] = "عدد التكرار"
    i = 0
    Set d = CreateObject("Scripting.Dictionary")
    For Each rng In ws.Range("c2:f" & lr)
        If rng <> "" Then
            If d.exists(rng.Value) Then
                d(rng.Value) = d(rng.Value) + 1
            Else
                d.Add rng.Value, 1
            End If
        End If
    Next

    For Each var In d.keys
'(M) سيتم وضع الاسماء في العمود 
'(N)وعدد تكرارها في العمود  
     Range("M" & (i + 2)) = var
       Range("N" & (i + 2)) = d(var)
        i = i + 1
       
    Next
    
    myrng.Borders.Weight = xlThin
    Range("N2:N" & lr).Font.Color = 255

Set d = Nothing
    Application.ScreenUpdating = True

End Sub

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

بالتوفيق

countif_V2.xlsm

countif_V3.xlsm

تم تعديل مايو 2, 2023 بواسطه Mohamed Hicham

أبو عبد الله _ · مايو 2, 2023

21 ساعات مضت, Mohamed Hicham said:

تنبيه عند تكرار نفس القيمة 10 مرات

السلام عليكم

اولا سلمت يداك

المطلوب التنبية عند تكرار نفس القيمة اكثر من ١٠ مرات

بخصوص السؤال الثاني

ما اقصده ان يتم تظليل الخلايا من c الى f

اذا كانت هناك بيانات مكررة في العمود c مع العلم ان البيانات في العمود c هي الاسم مثلا وقد يتكرر والعمود d الى f بيانات مختلفة

شرط التنسيق التكرار في العمود c بغض النظر عما هو مكتوب في باقي الأعمدة

المطلوب الكود الذي قمت باضافته في الزر المسمى بشرط تكرار القيمة في العمود c بشرط ان يعمل تلقائي عند كتابة قية في العمود C

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

.... كيف يمكنني معرفة اللون ورقمه

تم تعديل مايو 2, 2023 بواسطه أبو عبد الله _

**محمد هشام.** · مايو 2, 2023

تفضل اخي

countif_V4.xlsm

**محمد هشام.** · مايو 2, 2023

تفضل اخي تم تعديل الكود ليشتغل معك تلقائيا عند التغيير في عمود (c) واظافة امكانية اختيار الالوان . يمكنك تعديلها على حسب احتياجاتك .

'''تنبيه عند تكرار نفس القيمة في العمود اكثر من 10 مرات
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Dim cell As Range
Dim myrng As Range
Dim clr As Long
Dim lastCell As Range
Dim MH As Variant
Dim Idx As Long
    
    With Target
    ' تحديد رقم العمود الهدف
              If (.Column <> 3) Or .Cells.Count > 10 Then Exit Sub
On Error Resume Next
   ' تحديد اقصى عدد للتكرار المسموح به
        If WorksheetFunction.CountIf(Columns(.Column), .Value) > 10 Then
           'حدف القيمة المدخلة
            .clear
  MsgBox "لايمكن طباعة أكثر من 10", vbMsgBoxRight + vbOKOnly, "لا يمكن الاستمرار"

        End If
    End With
   
    Set ws = ThisWorkbook.Sheets("Sheet1")
    'النطاق الهدف
    Set myrng = ws.Range("c2:f" & Range("c" & ws.Rows.Count).End(xlUp).Row)
    ' نطاق الشرط
    Set myrng2 = ws.Range("c2:c" & Range("c" & ws.Rows.Count).End(xlUp).Row)

    With myrng
        Set lastCell = .Cells(.Cells.Count)
    End With
    myrng.Interior.ColorIndex = xlNone
'تحديد الالوان

MH = Array(RGB(255, 128, 128), RGB(204, 255, 255), RGB(51, 204, 204), RGB(204, 204, 204), _
RGB(153, 204, 0), RGB(255, 102, 0), RGB(255, 128, 128), _
 RGB(204, 204, 155), RGB(255, 255, 0), RGB(255, 153, 0), RGB(0, 255, 0), RGB(255, 0, 255))
 
    For Each cell In myrng
        If Application.WorksheetFunction.CountIf(myrng2, cell) > 1 Then
            If myrng.Find(what:=cell, lookat:=xlWhole, MatchCase:=False, after:=lastCell).Address = cell.Address Then
                cell.Interior.Color = MH(Idx)
                Idx = Idx + 1
            Else
                cell.Interior.ColorIndex = myrng.Find(what:=cell, lookat:=xlWhole, MatchCase:=False, after:=lastCell).Interior.ColorIndex
            End If
        End If
    Next
    ' يمكنك تغعيل السطر التالي في حالة الرغبة في استخراج عدد التكرار
    'Call test3
End Sub

countif_V5.xlsm

**أبو إيمان** · مايو 3, 2023

جزاكم الله خيرا

لقد وضعت مثالا ليكون المطلوب أكثر وضوحا

في 2‏/5‏/2023 at 13:06, أبو عبد الله _ said:

اقصده ان يتم تظليل الخلايا من c الى f

اذا كانت هناك بيانات مكررة في العمود c مع العلم ان البيانات في العمود c هي الاسم مثلا وقد يتكرر والعمود d الى f بيانات مختلفة

شرط التنسيق التكرار في العمود c بغض النظر عما هو مكتوب في باقي الأعمدة

البيانات في العمود من Dإلى F بيانات غير الاسماء مرتبطة بكل اسم قدد تتشابه وقد تختلف

ملاحظة : عند تكرار الاسماء ووصول الى الحد الاقصى تظهر رسالة ويقوم الكود بحذف الاسم الزائد عن العدد المحدد ( هذا ممتاز جدا )

لكن مع حذف الاسم يمسح تنسيقات حجم الخط ولونه ونوعه والمطلوب المحافظة على هذه التنسيقات

طلب اخير عند تفريغ الشيت من البيانات يمسح التنسيقات

countif_V6.xlsm

تم تعديل مايو 3, 2023 بواسطه أبو إيمان

**محمد هشام.** · مايو 4, 2023

شكرا لك اخي @أبو إيمان على التوضيح

تفضل اخي

Sub TEST_Rng()
Dim a As Variant, ST1 As Variant, MH As Variant, ST3 As Object
Dim WS_Data As Object, ST2 As Range, Data_Cells As Range, i As Long, Idx As Long
  
 Dim WS_Réf As Worksheet
Set WS_Réf = ThisWorkbook.Sheets("Sheet1")
 
 
Application.ScreenUpdating = False
 If WS_Réf.AutoFilterMode Then WS_Réf.AutoFilterMode = False
 Set ST2 = WS_Réf.Range("C2:F" & Range("C" & Rows.Count).End(xlUp).Row)
 
ST2.Interior.ColorIndex = xlNone
  a = Application.Index(ST2.Value2, , 1)
   Set WS_Data = CreateObject("Scripting.Dictionary")
     WS_Data.CompareMode = vbTextCompare
 
 For i = 1 To UBound(a)
    If a(i, 1) <> "" Then WS_Data(a(i, 1)) = WS_Data(a(i, 1)) + 1
    
  Next

 MH = Array(RGB(255, 128, 128), RGB(204, 255, 255), RGB(51, 204, 204), RGB(153, 153, 255), RGB(0, 255, 0), RGB(204, 204, 204), _
  RGB(255, 102, 0), _
 RGB(204, 204, 155), RGB(255, 255, 0), RGB(255, 153, 0), RGB(255, 0, 255))
  
  For Each ST1 In WS_Data.keys
    If WS_Data(ST1) > 1 Then
      ST2.Offset(-1).AutoFilter 1, ST1
      WS_Réf.AutoFilter.Range.Offset(1).Interior.Color = MH(Idx)
      Idx = Idx + 1
    End If
    
  Next
If WS_Réf.AutoFilterMode Then WS_Réf.AutoFilterMode = False
ST2.Offset(ST2.Rows.Count).Resize(1).Interior.Color = xlNone
For Each ST3 In WS_Réf.Range("C2:F500").Cells
  If ST3.Value = "" Then
    If Data_Cells Is Nothing Then
      Set Data_Cells = Range(ST3.Address)
Else
    Set Data_Cells = Union(Data_Cells, Range(ST3.Address))
  End If
    End If
      Next
      
Data_Cells.Interior.ColorIndex = xlNone


       Application.ScreenUpdating = True
End Sub

في حالة الرغبة بالتعامل مع جدول

Sub Color_Tbl()
  Dim a As Variant, MH As Variant, ST4 As Variant
  Dim Tab_WS As ListObject, ST5 As Object, WS_Data As Object
  Dim ST_Idx As Long, ST6 As Range, i As Long
  Dim Data_Cells As Range
  Dim ST_Réf As Worksheet
  Set ST_Réf = ThisWorkbook.Sheets("Sheet2")
 
  Application.ScreenUpdating = False

  Set Tab_WS = ST_Réf.ListObjects("Tableau1")
  Tab_WS.Range.AutoFilter
  Set ST6 = Tab_WS.DataBodyRange
  ST6.Interior.ColorIndex = xlNone
  a = Application.Index(ST6.Value2, , 1)
  Set WS_Data = CreateObject("Scripting.Dictionary")
  WS_Data.CompareMode = vbTextCompare
  For i = 1 To UBound(a)
    If a(i, 1) <> "" Then WS_Data(a(i, 1)) = WS_Data(a(i, 1)) + 1
  Next
 
MH = Array(RGB(255, 128, 128), RGB(204, 255, 255), RGB(51, 204, 204), _
 RGB(255, 102, 0), RGB(204, 204, 155), RGB(255, 255, 0), _
   RGB(255, 153, 0), RGB(255, 0, 255), RGB(153, 153, 255), RGB(0, 255, 0), RGB(204, 204, 204))
  
  For Each ST4 In WS_Data.keys
    If WS_Data(ST4) > 1 Then
      Tab_WS.Range.AutoFilter 1, ST4
      Tab_WS.Range.Offset(1).Interior.Color = MH(ST_Idx)
      ST_Idx = ST_Idx + 1
    End If
  Next
  Tab_WS.Range.AutoFilter
  ST6.Offset(ST6.Rows.Count).Resize(1).Interior.Color = xlNone
  For Each ST5 In ST_Réf.Range("C2:F500").Cells
  If ST5.Value = "" Then
    If Data_Cells Is Nothing Then
      Set Data_Cells = Range(ST5.Address)
Else
    Set Data_Cells = Union(Data_Cells, Range(ST5.Address))
  End If
    End If
      Next
      
Data_Cells.Interior.ColorIndex = xlNone
End Sub

بالتوفيق.......

countif_V7.xlsm

تم تعديل مايو 4, 2023 بواسطه Mohamed Hicham

تسجيل الدخول

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

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

أبو عبد الله _

محمد هشام.

محمد هشام.

أبو عبد الله _

محمد هشام.

محمد هشام.

أبو إيمان

محمد هشام.

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information