[已解决]请教如何以底色排序

songdg

For i = 1 To [A65536].End(xlUp).Row
If Application.WorksheetFunction.CountIf(Range("A:A"), Range("A" & i)) > 1 Then
Range("A" & i).Interior.Color = vbYellow
End If
Next

这段代码把第一列相同的项的底色都设为黄色，我想按照底色排序把黄底色的都排在上面。

最佳答案

月排行榜 / 总排行榜

爱疯

2016-8-2 10:56

Sub test()
    '1）填充颜色（条件格式）
    Columns(1).FormatConditions.Delete
    With Columns(1).FormatConditions.AddUniqueValues
        .DupeUnique = xlDuplicate
        .Interior.Color = vbYellow
    End With

    '2）按颜色排序
    With Sheets("sheet1").Sort
        .SortFields.Clear
        .SortFields.Add Key:=[a1].CurrentRegion, SortOn:=xlSortOnCellColor, Order:=xlDescending
        .SetRange [a1].CurrentRegion
        .Header = xlYes
        .Orientation = xlTopToBottom
        .Apply
    End With
End Sub

跳转到最佳答案楼层

mathking77

应该你要的效果是达到了，但我感觉这么做不是太完美，希望有大神能有更精辟的方法
Sub ClrSort()
For i = 2 To Range("a65536").End(xlUp).Row
If Application.WorksheetFunction.CountIf(Range("A:A"), Range("A" & i)) > 1 Then
Range("A" & i).Interior.Color = vbYellow
End If
Range("B" & i).Value = Range("A" & i).Interior.ColorIndex
Next
Columns("A:B").Sort Key1:=Range("B2"), Order1:=xlDescending, Header:=xlYes, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:=xlSortNormal
Columns("b:b").ClearContents
End Sub

scl5801

Sub zz()
    For i = 1 To [A65536].End(xlUp).Row
        If Application.WorksheetFunction.CountIf(Range("A:A"), Range("A" & i)) > 1 Then
           Range("A" & i).Interior.Color = vbYellow
        End If
    Next
    ActiveWorkbook.Worksheets("sheet1").Sort.SortFields.Clear
    Sheet1.Sort.SortFields.Add(Range("A1:A" & i), _
        xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = vbYellow
    With Sheet1.Sort
        .SetRange Range("A1:A" & i)
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

爱疯

Sub test()
    '1）填充颜色（条件格式）
    Columns(1).FormatConditions.Delete
    With Columns(1).FormatConditions.AddUniqueValues
        .DupeUnique = xlDuplicate
        .Interior.Color = vbYellow
    End With

    '2）按颜色排序
    With Sheets("sheet1").Sort
        .SortFields.Clear
        .SortFields.Add Key:=[a1].CurrentRegion, SortOn:=xlSortOnCellColor, Order:=xlDescending
        .SetRange [a1].CurrentRegion
        .Header = xlYes
        .Orientation = xlTopToBottom
        .Apply
    End With
End Sub

爱疯

Sub test2()
    Dim A, d, i
    A = Range("a1").CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(A)
        d(A(i, 1)) = d(A(i, 1)) + 1
    Next i
    For i = 2 To UBound(A)
        A(i, 1) = d(A(i, 1))
    Next i
    [b1].Resize(d.Count) = A

    Range("a1").CurrentRegion.Sort key1:=[b1], order1:=xlDescending, Header:=xlYes
    Range([a2], Range("b:b").Find(1).Offset(-1, -1)).Interior.ColorIndex = 6
    Range("b:b").ClearContents
End Sub


如果B列能做辅助列，可通过数组的值判断。
而不是读单元格属性，就快些。

有你才幸福

爱疯 发表于 2016-8-2 10:56
Sub test()
    '1）填充颜色（条件格式）
    Columns(1).FormatConditions.Delete

http://www.excelpx.com/thread-423115-1-1.html
老师帮忙弄下，谢谢了

songdg

爱疯 发表于 2016-8-2 10:56
Sub test()
    '1）填充颜色（条件格式）
    Columns(1).FormatConditions.Delete

谢谢，又学到新东西。但使用这种方法如何加入一个判断条件，有相同的项才运行第二步。还有就是B列有数据时排不到序。

爱疯

不必判断：
就算没相同的项，也执行条件格式，结果没有黄色单元格。

songdg

我的意思是想判断有没有重复的项，有的话就把重复的排在上面然后中断程序手动处理一下，没有就接着运行后面的程序。