Excel VBA - Macro to delete nearly duplicate rows based on criteria

[beese]

I have a very large excel table that appears as follows:
[TABLE="width: 500"]
<tbody>[TR]
[TD]Bob[/TD]
[TD]OH[/TD]
[TD]3[/TD]
[/TR]
[TR]
[TD]Bob[/TD]
[TD]OH[/TD]
[TD]4[/TD]
[/TR]
[TR]
[TD]Bob[/TD]
[TD]OH[/TD]
[TD]5[/TD]
[/TR]
[TR]
[TD]Mary[/TD]
[TD]OH[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]Mary[/TD]
[TD]OH[/TD]
[TD]3[/TD]
[/TR]
[TR]
[TD]Mary[/TD]
[TD]FLA[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]Ted[/TD]
[TD]AL[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]Ted[/TD]
[TD]AL[/TD]
[TD]3[/TD]
[/TR]
[TR]
[TD]Ted[/TD]
[TD]NY[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]Jim[/TD]
[TD]NY[/TD]
[TD]2[/TD]
[/TR]
</tbody>[/TABLE]
I want to delete rows leaving only the row with the max value in column 3
The final table should appear as follows:
[TABLE="width: 500"]
<tbody>[TR]
[TD]Bob[/TD]
[TD]OH[/TD]
[TD]5[/TD]
[TD]Note: Bob max of 3,4,5[/TD]
[/TR]
[TR]
[TD]Mary[/TD]
[TD]OH[/TD]
[TD]3[/TD]
[TD]Note: Mary OH max of 2, 3[/TD]
[/TR]
[TR]
[TD]Mary[/TD]
[TD]FLA[/TD]
[TD]2[/TD]
[TD]Note: Mary FLA max[/TD]
[/TR]
[TR]
[TD]Ted[/TD]
[TD]AL[/TD]
[TD]3[/TD]
[TD]Note: Ted AL max of 2,3[/TD]
[/TR]
[TR]
[TD]Ted[/TD]
[TD]NY[/TD]
[TD]2[/TD]
[TD]Note: Ted NY max[/TD]
[/TR]
[TR]
[TD]Jim[/TD]
[TD]NY[/TD]
[TD]2[/TD]
[TD]Note: Jim NY max[/TD]
[/TR]
</tbody>[/TABLE]
I am new to VBA and would appreciate any help you could give me.

 

[venkat1926]

your data is in sheet1 from A1 to c11

Excel Workbook
	A	B	C
1	name	state	data
2	Bob	OH	3
3	Bob	OH	4
4	Bob	OH	5
5	Mary	OH	2
6	Mary	OH	3
7	Mary	FLA	2
8	Ted	AL	2
9	Ted	AL	3
10	Ted	NY	2
11	Jim	NY	2
Sheet1

I have given three macro. park all the three macros in the standard module
save the file as macro enabled fille. close and open and enable macros

run only the macro "finalmacro" though other macros are parked in the module

Sub pivottable()
Dim r As Range
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("pivot").Delete


  Sheets.Add
  ActiveSheet.Name = "pivot"
  Worksheets("sheet1").Activate
  Set r = Range("A1").CurrentRegion
  r.Select
       ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        Selection, Version:=xlPivotTableVersion12).CreatePivotTable _
        TableDestination:="pivot!R3C1", TableName:="myPivotTable", DefaultVersion _
        :=xlPivotTableVersion12
    Sheets("pivot").Select
    Cells(3, 1).Select
    With ActiveSheet.PivotTables("myPivotTable").PivotFields("name")
        .Orientation = xlColumnField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("myPivotTable").PivotFields("state")
        .Orientation = xlRowField
        .Position = 1
    End With
    ActiveSheet.PivotTables("myPivotTable").AddDataField ActiveSheet.PivotTables( _
        "myPivotTable").PivotFields("data"), "Sum of data", xlSum
    With ActiveSheet.PivotTables("myPivotTable").PivotFields("Sum of data")
        .Caption = "Max of data"
        .Function = xlMax
    End With
application.displayalerts=true
End Sub

Sub arranging_data()


Dim rcol As Range, rrow As Range, ccol As Range, crow As Range, ddata As Integer
Dim dest As Range, j As Integer
Worksheets("pivot").Activate
Set rcol = Range(Range("A5"), Cells(Rows.Count, "A").End(xlUp).Offset(-1, 0))
Set rrow = Range(Range("C4"), Cells(4, Columns.Count).End(xlToLeft).Offset(0, -1))
Set dest = Range("a3").End(xlDown).Offset(5, 0)
For Each crow In rrow
For Each ccol In rcol
ddata = Application.Intersect(crow.EntireColumn, ccol.EntireRow)
If ddata = 0 Then GoTo nnext
dest = crow
dest.Offset(0, 1) = ccol
dest.Offset(0, 2) = ddata


Set dest = Cells(Rows.Count, dest.Column).End(xlUp).Offset(1, 0)
Debug.Print dest.Address
nnext:
Next ccol
Next crow




MsgBox "macro done.see sheet pivot and data bottom portion"


Application.DisplayAlerts = True
End Sub

Sub finalmacro()
pivottable
arranging_data
End Sub