[حل شده] مشخص کردن داده تکراری در سلول دیگر با تعداد تکرار

[rezayavar]

سلام فایلی دارم که هر روز تعداد 5 الی 10 رکورد بهش اضافه میشه و ممکنه تکراری باشه که حتما هم همین طوره میخواستم در سلول دیگه هم خود نماد رو بزنه هم تعداد تکرارش رو

[iranweld]

با سلام

در فایل پیوست با استفاده از رویدادها در اکسل چنانچه تغییری در ستون A ایجاد گردد یک لیست بدون تکرار از دیتای ستون A در ستون E ایجاد گردیده و در ستون مجاور تعداد تکرار آن درج میگردد

Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Me.Range("A:A")) Is Nothing Then
    
    On Error Resume Next
    
    Z1 = Sheet1.Cells(Sheet1.Rows.Count, "E").End(xlUp).Row
    
    Range("E2:F" & Z1 + 10) = ""
    
    
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("E2" _
        ), Unique:=True
        
              
        
        For I = 2 To Z1
        
        Range("F" & I) = Application.CountIf(Range("A:A"), Range("E" & I))
        
        Next
        
        End If
    
End Sub 

[rezayavar]

با سلام

در فایل پیوست با استفاده از رویدادها در اکسل چنانچه تغییری در ستون A ایجاد گردد یک لیست بدون تکرار از دیتای ستون A در ستون E ایجاد گردیده و در ستون مجاور تعداد تکرار آن درج میگردد

Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Me.Range("A:A")) Is Nothing Then
    
    On Error Resume Next
    
    Z1 = Sheet1.Cells(Sheet1.Rows.Count, "E").End(xlUp).Row
    
    Range("E2:F" & Z1 + 10) = ""
    
    
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("E2" _
        ), Unique:=True
        
              
        
        For I = 2 To Z1
        
        Range("F" & I) = Application.CountIf(Range("A:A"), Range("E" & I))
        
        Next
        
        End If
    
End Sub 

سلام ممنونم فقط اگه میشه لطف بفرمائید اونایی که یکبار تکرار شده رو نیاره و اونایی هم که تکرار شده از زیاد به کم مشخص بشه (بیشترین تکرار در راس باشه)

[iranweld]

فایل پیوست را بررسی نمایید

Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Me.Range("A:A")) Is Nothing Then
    
    On Error Resume Next
    
    
    Z2 = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
    
    Range("E2:F" & Z2) = ""
    
    Dim list1 As New Collection
   
     For I = 2 To Z2
        
        XX = Application.CountIf(Range("A:A"), Range("A" & I))
        
        If XX > 1 Then list1.Add Range("A" & I), CStr(Range("A" & I))
        
        Next
        
        For j = 1 To list1.Count
        
        Range("E" & j + 1) = list1.Item(j)
        
        Next
              
        Z1 = Sheet1.Cells(Sheet1.Rows.Count, "E").End(xlUp).Row
        For I = 2 To Z1
        
        Range("F" & I) = Application.CountIf(Range("A:A"), Range("E" & I))
        
        Next
        
      End If
    
End Sub 

[rezayavar]

فایل پیوست را بررسی نمایید

Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Me.Range("A:A")) Is Nothing Then
    
    On Error Resume Next
    
    
    Z2 = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
    
    Range("E2:F" & Z2) = ""
    
    Dim list1 As New Collection
   
     For I = 2 To Z2
        
        XX = Application.CountIf(Range("A:A"), Range("A" & I))
        
        If XX > 1 Then list1.Add Range("A" & I), CStr(Range("A" & I))
        
        Next
        
        For j = 1 To list1.Count
        
        Range("E" & j + 1) = list1.Item(j)
        
        Next
              
        Z1 = Sheet1.Cells(Sheet1.Rows.Count, "E").End(xlUp).Row
        For I = 2 To Z1
        
        Range("F" & I) = Application.CountIf(Range("A:A"), Range("E" & I))
        
        Next
        
      End If
    
End Sub 

سلام ببخشید نتونستم سریعتر خدمت برسم دستتون درد نکنه فقط این سورت نمیشه از زیاد به کم وقتی هم دستی سورت میکنم کلا جابجا میشه زحمت اینو رو هم میکشید ممنونم

[rezayavar]

فایل پیوست را بررسی نمایید

Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Me.Range("A:A")) Is Nothing Then
    
    On Error Resume Next
    
    
    Z2 = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
    
    Range("E2:F" & Z2) = ""
    
    Dim list1 As New Collection
   
     For I = 2 To Z2
        
        XX = Application.CountIf(Range("A:A"), Range("A" & I))
        
        If XX > 1 Then list1.Add Range("A" & I), CStr(Range("A" & I))
        
        Next
        
        For j = 1 To list1.Count
        
        Range("E" & j + 1) = list1.Item(j)
        
        Next
              
        Z1 = Sheet1.Cells(Sheet1.Rows.Count, "E").End(xlUp).Row
        For I = 2 To Z1
        
        Range("F" & I) = Application.CountIf(Range("A:A"), Range("E" & I))
        
        Next
        
      End If
    
End Sub 

سلام بازم ممنونم خیلی عالی فقط سوالی داشتم میشه وارد کردن اطلاعات از بالا اضافه بشه(ردیف a2)

[rezayavar]

سلام از اساتید و عزیزان بسیار تشکر میکنم برنامه به اون چیزی که میخواستم به کمک شما عزیزان رسید .
متشکرم
اکبریه