How to write a macro to selectively output certain data to a different table based on

[loveitlive]

Hi, I am trying to write a macro that does the following:
Original
Name Risk Rank
John A 1
John A 2
Mark C 3
Nancy A 2
Diane A 1
Diane B 1
Diane B 2
Diane C 2
Judy A 1
Judy A 2
Judy A 3


New
Name Risk Rank
John A 1
Mark C 3
Nancy A 2
Diane A 1
Diane B 1
Judy A 1


The table on the top is the original data and the one on the bottom i
the output. Basically, I am trying to let the macro loop through th
original table and only output to another table the rows with the lowes
rank for the same person and risk. I am pretty new to the excel macro
thanks a lot!!

 

[Bruno Campanini]

loveitlive formulated on Saturday :

Hi, I am trying to write a macro that does the following:
Original
Name Risk Rank
John A 1
John A 2
Mark C 3
Nancy A 2
Diane A 1
Diane B 1
Diane B 2
Diane C 2
Judy A 1
Judy A 2
Judy A 3


New
Name Risk Rank
John A 1
Mark C 3
Nancy A 2
Diane A 1
Diane B 1
Judy A 1


The table on the top is the original data and the one on the bottom is
the output. Basically, I am trying to let the macro loop through the
original table and only output to another table the rows with the lowest
rank for the same person and risk. I am pretty new to the excel macro,
thanks a lot!!!

May be it is too complicated... but it works.

===============================================
Public Sub SpecialNewTable()
Dim SourceRange As Range, NoDups As New Collection
Dim TargetRange As Range, i As Range, k As Long

' Definitions -----------------
Set TargetRange = [Sheet1!E1]
Set SourceRange = [Sheet1!A1]
' -----------------------------

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set SourceRange = Range(SourceRange, SourceRange.End(xlDown))
For Each i In SourceRange
On Error GoTo Dup_Err
NoDups.Add i(1, 1) & "*" & i(1, 2) & "*" & i(1, 3), _
CStr(i(1, 1) & "*" & i(1, 2) & "*" & i(1, 3))
k = k + 1
TargetRange(k, 1) = i(1, 1) & "*" & i(1, 2) & "*" & i(1, 3)
Continue:
On Error GoTo 0
Next

Set TargetRange = Range(TargetRange, TargetRange.End(xlDown))
TargetRange.Sort _
Key1:=TargetRange(1, 1), _
Order1:=xlAscending, _
Orientation:=xlSortColumns, _
MatchCase:=False

For Each i In TargetRange
i(1, 2) = Mid(i, InStr(1, i, "*") + 1, _
Len(i) - InStrRev(i, "*", -1))
i(1, 3) = Right(i, Len(i) - InStrRev(i, "*", -1))
i(1, 1) = Left(i, InStrRev(i, "*", -1) - 1)
Next

For k = TargetRange.Count - 1 To 1 Step -1
If TargetRange(k) = TargetRange(k + 1) Then
TargetRange(k + 1, 1).ClearContents
TargetRange(k + 1, 2).ClearContents
TargetRange(k + 1, 3).ClearContents
End If
Next

Range(TargetRange, TargetRange.Offset(, 3)).Sort _
Key1:=TargetRange(1, 1), _
Order1:=xlAscending, _
Orientation:=xlSortColumns, _
MatchCase:=False

Set TargetRange = Range(TargetRange(1, 1), TargetRange.End(xlDown))
For Each i In TargetRange
i(1, 1) = Left(i, InStr(1, i, "*") - 1)
Next

Exit_Sub:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Exit Sub

Dup_Err:
Resume Continue

End Sub
=================================================

Bruno

 

[Ben McClave]

Hello,

Here is a different approach that also seems to work. This macro copies all data to a new sheet, sorts by Rank, removes duplicates based on Name and Risk, then sorts by name.

Sub ReduceRisk()
Dim rData As Range
Dim ws As Worksheet
Dim lRows As Long

Set rData = Sheet1.Range("A2:C13") 'Data range with Headers
Set ws = Worksheets.Add

rData.Copy ws.Range("A1")
Set rData = ws.UsedRange
lRows = rData.Rows.Count

With ws.Sort
.SortFields.Clear
.SortFields.Add Key:=ws.Range("C2:C" & lRows) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=ws.Range("A2:A" & lRows) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange ws.Range("A2:C" & lRows)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

ws.Range("A2:C" & lRows).RemoveDuplicates Columns:=Array(1, 2), Header _
:=xlNo

With ws.Sort
.SortFields.Clear
.SortFields.Add Key:=ws.Range("A2:A" & lRows) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange ws.Range("A2:C" & lRows)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

End Sub

 

[Bruno Campanini]

Ben McClave wrote :

Hello,

Here is a different approach that also seems to work. This macro copies all
data to a new sheet, sorts by Rank, removes duplicates based on Name and
Risk, then sorts by name.

I used the very same technique, with the only difference of using the
same (TargetRange) range in the originally sheet.

But there should be a more elegant way of FINDing with multiple WHAT:=
May be with SQL query???

Bruno