Question

我有一个邮政编码列表，它们对应的县及其数量，按数量从最大到最小排序。但是，我需要以某种方式重新排列列表，以便在数量不受影响时，重复数据彼此相邻。对于着色部分，我只想将字体颜色一次添加到可以在两个县的邮政编码中。

我做的是添加了一个帮助栏，A并使用countif功能查找重复的邮政编码并为所有重复项添加字体颜色，所以不是我想要的结果。我认为它与发现重复，插入和复制有关，我不熟悉。

Sub test()        
    Dim Rng1, Rng2, cell As Range
    Dim LR1, LR2 As Long

    LR1 = Cells(Rows.Count, "B").End(xlUp).Row

    Set Rng1 = Range("B2", "B" & LR1)

    For i = 2 To LR1
        Cells(i, 1).Value = Application.WorksheetFunction.CountIf(Rng1, Cells(i, 2).Value)
    Next i

    Set Rng2 = Range("A2", "A" & LR1)

    For Each cell In Rng2
        If cell.Value > 1 Then
            cell.Offset(, 1).Font.Color = RGB(255, 0, 0)
            Else
        End If
    Next cell
End Sub

请看欲望结果的图片。如你所见，邮政编码32413可以是Walton或Bay County，所以我需要将第二个条目移到第一个条目下方。另外，我只想在两个县的第二次邮政编码中添加字体颜色。

Answer 1

我刚刚构建并测试了它并且它可以工作：

Option Explicit

Sub StackedSortByZip()

    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")

    With ws

        Dim rZip As Range
        Set rZip = .Range("B2:B12")

        Dim rCel As Range
        For Each rCel In rZip

            'look for another occurence of zip code
            Dim rFound As Range
            Set rFound = Range(rCel.Offset(1), rCel.End(xlDown)).Find(rCel, lookat:=xlWhole)

            'if it's found
            If Not rFound Is Nothing Then
                rFound.Resize(1, 3).Cut ', cut the zip with lower quantity
                'insert under original zip (as long as it's not last line)
                If rFound.Address <> rCel.Offset(1).Address Then rCel.Offset(1).Insert Shift:=xlDown
            End If

        Next

        'set conditional formatting
        With rZip
            .FormatConditions.Add Type:=xlExpression, Formula1:="=B1=B2"
            With .FormatConditions(.FormatConditions.Count)
                .SetFirstPriority
                .Font.Color = 255
            End With
        End With


    End With

End Sub

vba着色重复和重新排序列表

1 个答案: