HELP! How to change a square array into three colunms

[rballesteros]

Hi,
I'm trying to come up with a formula that will take a square matrix (distance between cities) and transform it into three columns. The first column is the city going FROM. The second column is the city you're going TO. And the last column is the actual DISTANCE.
Also, it will need to be able to add another city and get adjusted automatically.
Any ideas?
Thank you

 

[venkat1926]

suppose sample data is like this (a,s d are city names) from A1 down and to risght

<table width="256" border="0" cellpadding="0" cellspacing="0"><col style="width: 48pt;" width="64" span="4"> <tbody><tr style="height: 12.75pt;" height="17"> <td style="height: 12.75pt; width: 48pt;" width="64" height="17">
</td> <td style="width: 48pt;" width="64">a</td> <td style="width: 48pt;" width="64">s</td> <td style="width: 48pt;" width="64">d</td> </tr> <tr style="height: 12.75pt;" height="17"> <td style="height: 12.75pt;" height="17">a</td> <td align="right">0</td> <td align="right">37</td> <td align="right">88</td> </tr> <tr style="height: 12.75pt;" height="17"> <td style="height: 12.75pt;" height="17">s</td> <td align="right">37</td> <td align="right">0</td> <td align="right">100</td> </tr> <tr style="height: 12.75pt;" height="17"> <td style="height: 12.75pt;" height="17">d</td> <td align="right">88</td> <td align="right">100</td> <td align="right">0</td> </tr> </tbody></table>

try this macro "test" (the macro undo is to undo the result of the macro)

Sub test()
Dim r As Range, c As Range, dest As Range, j As Integer, dist As Double, k As Integer
Set r = Range(Range("A2"), Range("A2").End(xlDown))
k = Range("a2").End(xlDown).Row
For Each c In r
For j = 1 To 2
Set dest = Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
If c = c.Offset(0, j + 1).End(xlUp) Then GoTo nextc
Cells(dest.Row, "A") = c & " " & "to" & " " & c.Offset(0, j + 1).End(xlUp)
Cells(dest.Row, "b") = Intersect(Rows(c.Row), Columns(c.Offset(0, j + 1).Column))
Next j
nextc:
Next c
Range(Cells(k + 1, "A"), Cells(k + 4, "A")).EntireRow.Insert
End Sub

Sub undo()
Dim j As Integer
Range(Cells(j + 5, "a"), Cells(Rows.Count, "A")).EntireRow.Delete
End Sub

 

[Asator]

If you use some helper columns, you can do it with formulas alone, assuming F1 is the top left corner of your matrix.

A1: value: 1
A2: formula:
=IF(A1=COUNT(matrix x axis values),1,I25+1)

B1: value: 1
B2: formula:
=IF(A2=1,B1+1,B1)

Drag both formulas down from A2 and B2 until all combinations are met (rows x columns).

Col C is "from", col D is "to", col E is "distance"
Col C formula:
=offset($F$1,A1,0)

Col D formula:
=offset($F$1,0,B1)

Col E formula:
=offset($F$1,A1,B1)

Drag these formulas down. QED.

 

[venkat1926]

I have made the macro more general even if it more than 3x3 matrix, (even it is 4x4 or more)

Sub test()
Dim r As Range, c As Range, dest As Range, j As Integer, dist As Double, k As Integer
Set r = Range(Range("A2"), Range("A2").End(xlDown))
k = Range("a2").End(xlDown).Row
For Each c In r
k = Range("a2").End(xlToRight).Column

For j = 1 To k - 2
Set dest = Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
If c = c.Offset(0, j + 1).End(xlUp) Then GoTo nextc
Cells(dest.Row, "A") = c & " " & "to" & " " & c.Offset(0, j + 1).End(xlUp)
Cells(dest.Row, "b") = Intersect(Rows(c.Row), Columns(c.Offset(0, j + 1).Column))
Next j
nextc:
Next c
Range(Cells(k + 1, "A"), Cells(k + 4, "A")).EntireRow.Insert
End Sub

Sub undo()
Dim j As Integer
j = Range("a2").End(xlDown).Row
Range(Cells(j + 5, "a"), Cells(Rows.Count, "A")).EntireRow.Delete
End Sub

 

[rballesteros]

Thanks venkat1926!
It realy worked. I made some small changes to it and it works great!

Now I need to do peertty much the opposet.
I need to convert three columns into a matrix. Something like this"

FROM THIS:
A A 0
A B 10
A C 25
B A 35
B B 0
B C 100
C A 2
C B 22
C C 6

TO THIS:
A B C
A 0 10 25
B 35 0 100
C 2 22 6

Hope youcan help me.
Thanks

 

[venkat1926]

data is like this with column headings

Excel Workbook
	A	B	C
1	hdng1	hdng2	hdng3
2	A	A	0
3	A	B	10
4	A	C	25
5	B	A	35
6	B	B	0
7	B	C	100
8	C	A	2
9	C	B	22
10	C	C	6
Sheet1

then run the macro

Sub matrix()
Dim r As Range, rfilt As Range, rfull As Range
Dim c As Range, cfinda As Range, cfindb As Range, x As Double

Set r = Range(Range("A1"), Range("A1").End(xlDown))
Set rfilt = Range("A1").End(xlDown).Offset(5, 0)
r.AdvancedFilter xlFilterCopy, , rfilt, True
Set rfilt = Range(rfilt.Offset(1, 0), rfilt.End(xlDown))
rfilt.Copy
rfilt.Cells(1, 1).Offset(-1, 1).PasteSpecial , Transpose:=True

For Each c In r.Offset(1, 0).Resize(r.Rows.Count - 1, r.Columns.Count)
x = c.Offset(0, 2)
Set cfinda = rfilt.Cells.Find(what:=c.Value, lookat:=xlWhole)
Set cfindb = Rows(rfilt.Cells(1, 1).Offset(-1, 0).Row).Cells.Find(what:=c.Offset(0, 1).Value, lookat:=xlWhole)
Application.Intersect(Rows(cfinda.Row), Columns(cfindb.Column)) = x
Next c
End Sub

se 5 rows down the main data.