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

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

أبو عبد الله _
 مشاركة

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

أبو عبد الله _

أبو عبد الله _

قام بنشر
قام بنشر

السلام عليكم 

المطلوب

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

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

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

 

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

countif.xlsm

رابط هذا التعليق
شارك
محمد هشام.

محمد هشام.

قام بنشر
قام بنشر

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

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

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

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

رابط هذا التعليق
شارك
محمد هشام.

محمد هشام.

قام بنشر
قام بنشر (معدل)

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

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

''تنبيه عند تكرار نفس القيمة في العمود اكثر من 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

تم تعديل بواسطه Mohamed Hicham
  • Like 4
رابط هذا التعليق
شارك
أبو عبد الله _

أبو عبد الله _

قام بنشر
  • الكاتب
قام بنشر (معدل)
21 ساعات مضت, Mohamed Hicham said:

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

السلام عليكم 

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

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

 

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

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

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

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

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

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

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

 

تم تعديل بواسطه أبو عبد الله _
رابط هذا التعليق
شارك
محمد هشام.

محمد هشام.

قام بنشر
قام بنشر

تفضل اخي تم تعديل الكود ليشتغل معك تلقائيا عند التغيير في عمود (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

 p_2678i8hzf1.png

 

countif_V5.xlsm

  • Like 2
رابط هذا التعليق
شارك
أبو إيمان

أبو إيمان

قام بنشر
قام بنشر (معدل)

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

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

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

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

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

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

 

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

 

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

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

 

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

countif_V6.xlsm

تم تعديل بواسطه أبو إيمان
  • Like 1
رابط هذا التعليق
شارك
محمد هشام.

محمد هشام.

قام بنشر
قام بنشر (معدل)

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

تفضل اخي  

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

تم تعديل بواسطه Mohamed Hicham
  • Like 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

  I accept