Need Help: Creating a Matrix

[dankenny]

Hi,

I have a dataset with the following structure.


ColumnA------>ColumnB------>ColumnC------>ColumnD
ClassA ------>OtherStud------>WorkWith------>PlayWith

AA ------> DD ------> 1 ----------> 0
AA ----------> EE ------> 0 ----------> 1
AA ----------> BB ------> 1 ----------> 1
BB ----------> FF ------> 1 ----------> 0
BB ----------> GG ------> 1 ----------> 1
BB ----------> KK ------> 0 ----------> 1
CC ----------> AA ------> 1 ----------> 1
CC ----------> BB ------> 1 ----------> 1


ColumnA refers to students in ClassroomA, and Column B refers to "Other Students" in the school who could act as work and/or playmates. Note, ColumnB could also include some of the same students in ClassroomA who work or play with each other (For example, Students: AA and BB).

If a Student in Classroom A works with a student in ClassroomB, ColumnC takes the value of 1, and 0(zero) if otherwise

If a student in Classroom A plays with a student in ClassroomB, ColumnD takes the value of 1, and 0 (zero), if otherwise

So, looking at ColumnA, we find that there are three students: AA, BB and CC.
Student_AA for instance interacts with three students <DD, EE, BB> but only works with DD and BB. Similarly, Student_CC interacts with two students <AA, and BB> and works and plays with each of them.

Now, I am interested in constructing 2 separate matrices indicating which students in ClassroomA (1) Work and (2) Play with each other. This means that student_AA for instance works with student_BB, who is in his/her classroom, hence the cell in their matrix will have a "1". Again, Student_CC in ClassroomA works with and plays with 2 other members of his/her own class<ie, AA and BB>. So CC would have two "1s" in the matrix.

The resulting matrix for the "Works With" relation (ColumnC) among the 3 students in ClassroomA would look like this.

AA BB CC
AA 0 1 0
BB 0 0 0
CC 1 1 0

This matrix is the output I am interested in. I would need to produce this matrix for the relation specified in columnC and ColumnD.

I would certainly appreciate some ideas to help me produce this.


Thanks in advance for your assistance.

Sincerely, DK

 

[jindon]

Hi

Sub test()
Dim a, i As Long, ii As Integer, iii As Integer, b(), dic1 As Object
Dim dic2 As Object, x, y, z, flg As Boolean
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
dic1.comparemode = vbtextcompare
dic2.comparemode = vbtextcompare
a = Range("a1").CurrentRegion.Resize(,3).Value
For i = 1 To UBound(a,1)
     If Not dic1.exists(a(i,1)) Then dic1.add a(i,1), Nothing
     If Not dic2.exists(a(i,2)) Then dic2.add a(i,2), Nothing
Next
ReDim b(1 To dic1.count + 1, 1 To dic2.count + 1)
x = dic1.item : y = dic2.item
z = WorksheetFunction.Max(dic1.Count, dic2.Count)
Set dic1 = Nothing : Set dic2 = Nothing
For i = 0 To z - 1
     If i <= UBound(x) Then b(i + 2,1) = x(i)
     If i <=UBound(y) Then b(1,i + 2) = y(i)
Next
For i = 1 To UBound(a,1)
     For ii = 2 To UBound(b,1)
          If b(ii,1) = a(i,1) Then
               For iii = 2 To UBound(b,2)
                    If b(1,iii) = a(i,2) Then
                         b(ii,iii) = b(ii,iii) + 1
                         flg = True : Exit For
                    End If
               Next
          End If
          If flg Then Exit For
     Next
     flg = False
Next
Range("e1").Resize(UBound(b,1), UBound(b,2)).Value = b
End Sub

 

[dankenny]

MrExcel_MVP

Thanks very much, MrExcel.

I really appreciate the quick reply.

I have two questions about the code....first how do I use it...(ie, where in Excel would I use it).

And secondly, do I have to adjust any part of the code to adjust for the number of items in ColumnA and ColumnB ?

Thanks very much again !!

/DK

 

[jindon]

Ah,,,

I've just read your question again and found my logic was wrong...

Just wait for a while...

 

[jindon]

1) hit Alt + F11 To open VB Editor
2) Go To [Insert] - [Module] then paste the code onto the right pane
3) hit Alt + F11 again to get back to Excel
4) hit Alt + F8 and choose "test" then hit "Run"
it will display the result in Sheet2
hope this works

Sub test()
Dim dic1 As Object, dic2 As Object, a, b(), i As Long, ii As Integer
Dim iii As Byte, x, y, z, c(), flg As Boolean
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
dic1.CompareMode = vbTextCompare
dic2.CompareMode = vbTExtCompare
a = Range("a1").CurrentRegion.Resize(,4).Value
For i = 1 To UBound(a,1)
     If Not dic1.exists(a(i,1)) Then dic1.add a(i,1), Nothing
     If Not dic2.exists(a(i,2)) Then dic2.add a(i,2), Nothing
Next
ReDim b(1 To dic1.Count + 1, 1 To dic2.count + 1)
ReDim c(1 To dic1.Count + 1, 1 To dic2.count + 1)
x = dic1.keys : y = dic2.keys
z = WorksheetFunction.Max(dic1.count, dic2.count)
Set dic1 = Nothing : Set dic2 = Nothing
For i = 0 To z - 1
     If i <= UBound(x) Then b(i + 2,1) = x(i) : c(i + 2,1) = x(i)
     If i <= UBound(y) Then b(1,i + 2) = y(i) : c(1,i + 2) = y(i)
Next
For i = 1 To UBound(a,1)
     For ii = 2 To UBound(b,1)
          If a(i,1) = b(ii,1) Then
               For iii = 2 To UBound(b,2)
                    If a(i,2) = b(1,iii) Then
                         If a(i,3) = 1 Then b(ii,iii) = 1
                         If a(i,4) = 1 Then c(ii,iii) = 1
                         flg = True : Exit For
                    End If
               Next
          End If
          If flg Then Exit For
     Next
     flg = False '<- added
Next
With Sheets("sheet2")
     .Range("a1").Resize(UBound(b,1), UBound(b,2)).Value = b
     .Range("a1").End(xlDown).Offset(2).Resize(UBound(c,1), UBound(c,2)).Value = c
End With
End Sub

Note: code has been edited 13:17 Tokyo time

 

[dankenny]

Thanks very much.

I run it and got "Runtime Error 9"

Subscript out of Range

Btw....do i need to add the column headers to the data in Excel?

Thanks....DK

 

[jindon]

OK

I've just edited the code so can you copy the code again and try?

I'm assuming there is no heading row...

 

[dankenny]

I am sorry......it is still giving the same runtime error....

sorry for the inconvenience...

Thanks DK

 

[jindon]

Don't worry, that's because I don't test the code for myself.

Can you tell me which line was hilighted when you debug?

 

[dankenny]

This line:

With Sheets("sheet2")


Close to the end of the program


thanks - DK