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

[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]

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