Excel宏从向量中获取值以填充矩阵

我不确定这个标题是否足够具有描述性

基本上我有很多向量（大约50个），每个向量包含几百个值。每个向量都标有一个数字，它们看起来像这样：

Vector 1
Stim1     12
Stim5     36
Stim7     24
Stim10    4
...       ...

Vector 2
Stim2     28
Stim3     33
Stim5     9
Stim8     40
...       ...

也就是说，它们有一个与特定刺激标签（StimX）相关联的数字。然而，每个向量都由一组唯一的刺激标签填充；一些刺激标签在多个向量之间共享-但是，每个向量并不包含每个刺激标签，并且每个向量都不共享一个刺激标签。例如，向量2看起来像这样：

Vector 1
Stim1     12
Stim5     36
Stim7     24
Stim10    4
...       ...

Vector 2
Stim2     28
Stim3     33
Stim5     9
Stim8     40
...       ...

及

此外，每个向量都有数量可变的值。。。有的有200个，有的有300个，等等

我想做的是创建一个宏，它将根据这些向量值填充矩阵。所以矩阵看起来像：

        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
...  

---

我对VBA不是很了解，所以我相信这可以很简单地完成。

我假设sheet1和sheet2中的向量和刺激列表将显示矩阵

A列-向量和刺激
B列-对应的

此代码将执行以下操作：

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

---

如果你有任何问题，请提问

谢谢你的快速回复！粗略一看，它看起来相当不错。不幸的是，我今天没有偶然发现；我的电脑有问题，机器上有数据，所以我可能需要一两天才能真正验证这一点。只是在Excel中的一些合成数据上运行它，它似乎工作得很好。太好了！请记住，首先在源数据的副本上运行此操作。祝你好运