formating macro based on criteria

[alvbnp]

I have column B which filled in with number in ascending sorted. But this list might have number that are the same. Is it possible to have a macro to find the same number then add border into it?

eg:
b1 = 11
b2 = 12
b3 = 13
b4 = 13
b5 = 14
b6 = 15
b7 = 15
b8 = 15
b9 = 16

from the sample above, b3 & b4 are same, put border from b3 to h4. so that it highlight the whole thing. same as for b6 to h8.

besides that, also need to put autosum c3:c4 in h4, autosum c6:c8 in h8.

Thanks.

 

[pgc01]

Hi alvbnp

To format the duplicates you don't need a macro, use Conditional Formatting.

Select B1:B9
Format>Conditional Formatting, in Condition 1 choose Formula Is and enter the formula

=COUNTIF($B:$B,B1)>1

Then click on the Format button and choose the colour for the background.

Hope this helps
PGC

 

[pgc01]

Hi again

Just saw that you also want the autosum

In H1:

=IF(COUNTIF($B$1:$B$9,B1)=1,"",IF(COUNTIF(B1:$B$9,B1)=1,SUMIF($B$1:$B$9,B1),""))

Copy down

Kind regards
PGC

 

[Andrew Poulsom]

Try this macro:

Sub Test()
    Dim Rng As Range
    Dim Cell As Range
    Dim List As New Collection
    Dim Item As Variant
    Dim Rng1 As Range
    Application.ScreenUpdating = False
    With Worksheets("Sheet1")
        Set Rng = .Range("B1:B" & .Cells(.Rows.Count, 2).End(xlUp).Row)
        Rng.Resize(Rng.Rows.Count, 7).Borders.LineStyle = xlLineStyleNone
        For Each Cell In Rng
            On Error Resume Next
            List.Add Cell.Value, Format(Cell.Value, Cell.NumberFormat)
        Next Cell
        On Error GoTo 0
        .Rows(1).EntireRow.Insert
        .Cells(1, 2).Value = "List"
        Set Rng = .Range("B1:B" & .Cells(.Rows.Count, 2).End(xlUp).Row)
        For Each Item In List
            Rng.AutoFilter
            Rng.AutoFilter Field:=1, Criteria1:=Item
            Set Rng1 = Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1, 7)
            Set Rng1 = Rng1.SpecialCells(xlCellTypeVisible)
            With Rng1
            If .Rows.Count > 1 Then
                .BorderAround xlContinuous
                .Cells(.Rows.Count, .Columns.Count).Formula = "=SUM(" & .Columns(1).Address(False, False) & ")"
            End If
            End With
        Next Item
        .AutoFilterMode = False
        .Rows(1).EntireRow.Delete
    End With
    Application.ScreenUpdating = True
End Sub