formating macro based on criteria

alvbnp

Board Regular
Joined
Jun 26, 2006
Messages
180
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.
 

Some videos you may like

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.

pgc01

MrExcel MVP
Joined
Apr 25, 2006
Messages
19,870
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

MrExcel MVP
Joined
Apr 25, 2006
Messages
19,870
Hi again

Just saw that you also want the autosum

In H1:

Code:
=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

MrExcel MVP
Joined
Jul 21, 2002
Messages
73,092
Try this macro:

Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,113,861
Messages
5,544,723
Members
410,630
Latest member
JFORTH97
Top