نوشته اصلی توسط
Rose1
دوست عزیز متاسفانه فرمولی که استفاده کردین رو نمیتونم پیدا کنم + در خصوص فایل های تکراری باز هم مشکل وجود دارد
با سلام
در فایل جدید تکراری های 5 تای ماکزیمم هر کدام به همان رنگ اختصاص یافته، تغییر مینمایند
این فایل با ویژوال بیسیک تهیه گردیده است
در این فایل ابتدا برای هر ستون ، یک ستون بدون اعداد تکراری با ADVANCE FILTTER تهیه گردیده و سپس پنج عدد ماکزیمم هر ستون مشخص گردیده و سپس در ستون اصلی جستجو صورت گرفته و اعداد ماکزیمم بهمراه اعداد تکراری آنها شناسایی شده و به رنگ مورد نظر تغییر مییابند
سپس ستون های کمکی ایجاد شده پاک میشود
کد PHP:
Sub MAX()
Dim rng As Range
Dim MAX As Double
Application.ScreenUpdating = False
Z = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
Range("A1:Q" & Z).Select
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
Range("A1").Select
CLEAR
Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("K1" _
), Unique:=True
Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("L1" _
), Unique:=True
Columns("C:C").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("M1" _
), Unique:=True
Columns("D:D").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("N1" _
), Unique:=True
'=======================================
Z = Sheet1.Cells(Sheet1.Rows.Count, "K").End(xlUp).Row
Set rng = Sheet1.Range("K1:K" & Z)
For T = 1 To 5
MAX = Application.WorksheetFunction.Large(rng, T)
Y = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
For I = 1 To Y
If Cells(I, 1).Value = MAX Then
Cells(I, 1).Font.ColorIndex = T + 2
End If
Next I
Next T
'=======================================
Z = Sheet1.Cells(Sheet1.Rows.Count, "L").End(xlUp).Row
Set rng = Sheet1.Range("L1:L" & Z)
For T = 1 To 5
MAX = Application.WorksheetFunction.Large(rng, T)
Y = Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row
For I = 1 To Y
If Cells(I, 2).Value = MAX Then
Cells(I, 2).Font.ColorIndex = T + 2
End If
Next I
Next T
'================================
Z = Sheet1.Cells(Sheet1.Rows.Count, "M").End(xlUp).Row
Set rng = Sheet1.Range("M1:M" & Z)
For T = 1 To 5
MAX = Application.WorksheetFunction.Large(rng, T)
Y = Sheet1.Cells(Sheet1.Rows.Count, "C").End(xlUp).Row
For I = 1 To Y
If Cells(I, 3).Value = MAX Then
Cells(I, 3).Font.ColorIndex = T + 2
End If
Next I
Next T
'================================
Z = Sheet1.Cells(Sheet1.Rows.Count, "N").End(xlUp).Row
Set rng = Sheet1.Range("N1:N" & Z)
For T = 1 To 5
MAX = Application.WorksheetFunction.Large(rng, T)
Y = Sheet1.Cells(Sheet1.Rows.Count, "D").End(xlUp).Row
For I = 1 To Y
If Cells(I, 4).Value = MAX Then
Cells(I, 4).Font.ColorIndex = T + 2
End If
Next I
Next T
'===================
CLEAR
End Sub
پاسخ با نقل قول
علاقه مندی ها (Bookmarks)