Snasui Excel Forum

Code: Select all

ActiveWorkbook.Worksheets("test").sort.SortFields.Clear
ActiveWorkbook.Worksheets("test").sort.SortFields.Add Key:=Range("k6:K17"), _
    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("test").sort
    .SetRange Range("J5:K16")
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

Code: Select all

Dim rall As Range, icount As Long
Dim r1 As Range, r2 As Range
Dim c As New Collection, item As Variant
With ActiveSheet
    Set rall = Union(.[b3:e5], .[b19:e24])
    .Range("j6:j1000,o6:o1000").ClearContents
    For Each r1 In rall
        icount = 0
        For Each r2 In rall
            If r1.Value = r2.Value Then
                icount = icount + 1
            End If
        Next r2
        On Error Resume Next
        If icount > 1 Then
            c.Add CStr(r1.Value), CStr(r1.Value)
        End If
        On Error GoTo 0
    Next r1
    For Each item In c
        If CLng(item) <= .[j2] Then
            .Range("j" & .Rows.Count).End(xlUp) _
                .Offset(1, 0).Value = CLng(item)
        Else
            .Range("o" & .Rows.Count).End(xlUp) _
                .Offset(1, 0).Value = CLng(item)
        End If
    Next item
End With