Excel macro take values from vector to populate matrix - excel

Question

I'm not sure if this title is descriptive enough.
So basically I have a number of vectors (about 50 of them), each containing several hundred values. Each vector is labelled with a number, and they look something like this:
Vector 1
Stim1 12
Stim5 36
Stim7 24
Stim10 4
... ...
That is, they have a number associated with a specific stimulus label (StimX). However, each vector is populated by a unique set of stimulus labels; some stimulus labels are shared between multiple vectors - however, each vector does not contain every stimulus label, and no one stimulus label is shared by every vector. So, for example, Vector 2 would look like this:
Vector 2
Stim2 28
Stim3 33
Stim5 9
Stim8 40
... ...
and
Vector 3
Stim4 50
Stim3 10
Stim7 4
Stim11 22
... ...
Furthermore, each vector has a variable number of values ... some have 200, others 300, etc.
What I want to do is create a macro that will populate a matrix based on these vector values. So the matrix would look something like:
Vector 1 Vector 2 Vector 3 ...
Stim1 12
Stim2 28
Stim3 33 10
Stim4 50
Stim5 36 9
Stim6
Stim7 24 4
Stim8 40
Stim9
Stim10 4
Stim11 22
...
I don't really know VBA that well, so I am sure this can be done pretty simply.

Answer 1

I have assumed that your Vector and Stim list in sheet1, and sheet2 will display your matrix.
Column A - vectors and stims
Column B - corresponding #s
This code will do the job:
Option Explicit
Sub cMatrix()
Dim i As Long
Dim j As Long
Dim cnt As Long
cnt = 2
Dim tmp As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim arr() As String
Set ws1 = ThisWorkbook.Sheets(1)
Set ws2 = ThisWorkbook.Sheets(2)
' populate Y axis: list of stims
For i = 1 To ws1.Range("A" & Rows.Count).End(xlUp).Row
If StrComp(CStr(Left(ws1.Range("A" & i), 1)), "s", vbTextCompare) = 0 Then
ws2.Range("A" & cnt).Value = ws1.Range("A" & i).Value
cnt = cnt + 1
End If
Next i
' populate X axis: vectors
cnt = 2
For i = 1 To ws1.Range("A" & Rows.Count).End(xlUp).Row
If StrComp(CStr(Left(ws1.Range("A" & i), 1)), "v", vbTextCompare) = 0 Then
ws2.Cells(1, cnt).Value = ws1.Range("A" & i).Value
cnt = cnt + 1
End If
Next i
' fill array
ReDim arr(ws2.Range("A" & Rows.Count).End(xlUp).Row - 1)
For i = 2 To ws2.Range("A" & Rows.Count).End(xlUp).Row
arr(i - 2) = ws2.Range("A" & i).Value
ws2.Range("A" & i).ClearContents
Next i
' remove duplicate
Call RemoveDuplicate(arr)
' reprint stims
For i = LBound(arr) To UBound(arr)
ws2.Range("A" & i + 2).Value = arr(i)
Next i
' fill matrix
For cnt = 2 To ws2.Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To ws1.Range("A" & Rows.Count).End(xlUp).Row
If StrComp(ws2.Cells(1, cnt).Value, ws1.Range("A" & i).Value, vbTextCompare) = 0 Then
j = i + 1
While StrComp(Left(ws1.Range("A" & j).Value, 1), "S", vbTextCompare) = 0
For tmp = 2 To ws2.Range("A" & Rows.Count).End(xlUp).Row
If (StrComp(ws2.Range("A" & tmp).Value, ws1.Range("A" & j).Value, vbTextCompare) = 0) Then
ws2.Cells(tmp, cnt).Value = ws1.Range("B" & j).Value
j = j + 1
End If
Next tmp
Wend
End If
Next i
Next cnt
End Sub
Public Sub RemoveDuplicate(ByRef StringArray() As String)
Dim LowBound As Long, UpBound As Long
Dim TempArray() As String, Cur As Long
Dim A As Long, B As Long
If (Not StringArray) = True Then Exit Sub
LowBound = LBound(StringArray)
UpBound = UBound(StringArray)
ReDim TempArray(LowBound To UpBound)
Cur = LowBound
TempArray(Cur) = StringArray(LowBound)
For A = LowBound + 1 To UpBound
For B = LowBound To Cur
If LenB(TempArray(B)) = LenB(StringArray(A)) Then
If InStrB(1, StringArray(A), TempArray(B), vbBinaryCompare) = 1 Then Exit For
End If
Next B
If B > Cur Then Cur = B: TempArray(Cur) = StringArray(A)
Next A
ReDim Preserve TempArray(LowBound To Cur)
StringArray = TempArray
End Sub
If you have any questions, please ask!