Hi all,

I've to find the 50 lowest values from a 200 x 200 correlation matrix
and copy it together with the names into a final list in a different
w/sheet. The matrix is of the form:

Name1 Name2 .... Name200
Name1 0.62 .... 0.15
Name2 .... 0.34
....
Name199 0.86

I would like to get an output of the following form:

Column A Column B Column C
Name1 Name200 0.15
Name67 Name 89 0.16
etc.

However, there are two things that make it more difficult:

1.) I would like to keep the original interior color of the names. Each
name has a interior colorindex representing a specific industry group
and I would like to have that reflected in the final list.

2.) Each name should only be included once in the final output, i.e. I
don't want any duplicates in the list of the companies with the lowest
correlation. For example, if name1/name200 form the first pair, then I
would like to make sure that both companies are not included in this
list anymore, even if e.g. name1/name70 has a very low correlation as
well.

Below is what I've done so far. It works except for point 2 above
(i.e.final list includes duplicates). The code uses an array to save
the names, the interior color of the names and the correlation, but I
don't know how to make sure that rows/columns that were used before are
ignored when looking for the next lowest value. Also the fact that I
change the value of the correlation and only use the "min" function is
probably not the most efficient to do.


sub matching_names_with_lowest_correlation()

Dim i As Integer, g As Integer, x As Integer, r As Integer
Dim q As Integer, p As Integer, t As Integer
Dim FirstCell As Range
Dim FoundCell As Range
Dim AllCells As Range
Dim workrange As Range
Dim mymatches(1 To 50, 1 To 5) As Variant

For i = 1 To 50

Set workrange = Selection
MinVal = Application.Min(workrange)
workrange.Find(What:=MinVal).Select

On Error Resume Next
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
q = Selection.Columns.count - 1
ActiveCell.Select
mymatches(i, 1) = ActiveCell
mymatches(i, 2) = ActiveCell.Interior.ColorIndex

ActiveCell.Offset(0, q).Select

ActiveCell.Select
Range(Selection, Selection.End(xlUp)).Select
p = Selection.Rows.count - 1
ActiveCell.Select
mymatches(i, 3) = ActiveCell
mymatches(i, 4) = ActiveCell.Interior.ColorIndex

ActiveCell.Offset(p, 0).Select
mymatches(i, 5) = ActiveCell

ActiveCell.Value = ActiveCell.Value + 1000
Selection.Interior.ColorIndex = 6

Selection.End(xlUp).Select
Selection.End(xlToLeft).Select

Next i
On Error GoTo 0


' Selects cells based on their formatting

ActiveCell.Offset(1, 1).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select

With Application.FindFormat
.Clear
.Interior.ColorIndex = 6
End With

'Look for first matching cell
Set FirstCell = ActiveSheet.UsedRange.Find(What:="",
SearchFormat:=True)

'Initialize AllCells
Set AllCells = FirstCell
Set FoundCell = FirstCell

'Loop until the FirstCell is found again
Do
Set FoundCell = ActiveSheet.UsedRange.Find _
(After:=FoundCell, What:="", SearchFormat:=True)
If FoundCell Is Nothing Then Exit Do
Set AllCells = Union(FoundCell, AllCells)
If FoundCell.Address = FirstCell.Address Then Exit Do
Loop

AllCells.Select

For Each cell In Selection
cell.Select
ActiveCell.Value = ActiveCell.Value - 1000
Selection.Interior.ColorIndex = 3
Next cell

Worksheets("FinalList").Select

t = 1
For p = 1 To 50

Cells(p, t) = mymatches(p, 1)
Cells(p, t).Interior.ColorIndex = mymatches(p, 2)
Cells(p, t + 1) = mymatches(p, 3)
Cells(p, t + 1).Interior.ColorIndex = mymatches(p, 4)
Cells(p, t + 2) = mymatches(p, 5)

Next p

End Sub



I'm really stuck at this point - any help is greatly appreciated!!!!

Rgds,
Manuel