Snasui Excel Forum

Code: Select all

Sub check()
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(.[b5:f21], .[j5:n21], .[r5:v21], .[z5:ad21], .[ah5:al21]) 'select Range
    .Range("b6:b1000,p6:p1000").ClearContents 'Clear Range
    For Each r1 In rall  'loop Range rall1
        icount = 0
        For Each r2 In rall 'loop range rall2
            If r1.Value = r2.Value Then
                icount = icount + 1
            End If
        Next r2
        On Error Resume Next 'if error run on
        If icount > 1 Then
            c.Add CStr(r1.Value), CStr(r1.Value) ' add value collection(item)
        End If
        On Error GoTo 0
    Next r1
    For Each item In c
        If CLng(item) <= .[b2] 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
'sort roll k
ActiveWorkbook.Worksheets("test").sort.SortFields.Clear
ActiveWorkbook.Worksheets("test").sort.SortFields.Add Key:=Range("c6:c100"), _
    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("test").sort
    .SetRange Range("b6:n100")
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

Code: Select all

Sub check()
Dim rall As Range, icount As Long
Dim r1 As Range, r2 As Range
Dim c As New Collection, item As Variant
With Sheets("cal")
    Set rall = Union(.[b5:f21], .[b31:h49], .[x31:ac49], .[j5:n21], .[r5:v21], .[z5:ad21], .[m31:s49], .[ag31:al49], .[ah5:al21], .[ap5:at21], .[ao29:at36]) 'select Range

    With Sheets("Result")
    .Range("c6:c1000,q6:q1000").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
            [b]c.Add CDbl(r1.Value), CDbl(r1.Value)[/b]
        End If
        On Error GoTo 0
    Next r1
    For Each item In c
        If CLng(item) <= .[c3] Then
            .Range("c" & .Rows.Count).End(xlUp) _
                .Offset(1, 0).Value = CLng(item)
        Else
            .Range("q" & .Rows.Count).End(xlUp) _
                .Offset(1, 0).Value = CLng(item)
        End If
    Next item
End With
End With
End Sub

Code: Select all

For Each item In c
    If CDbl(item) <= .[c3] Then
        .Range("c" & .Rows.Count).End(xlUp) _
            .Offset(1, 0).Value = CDbl(item)
    Else
        .Range("q" & .Rows.Count).End(xlUp) _
            .Offset(1, 0).Value = CDbl(item)
    End If
Next item