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

Question

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

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

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

也就是说，它们有一个与特定刺激标签 (StimX) 相关联的数字。然而，每个向量都由一组独特的刺激标签组成。一些刺激标签在多个向量之间共享 - 但是，每个向量不包含每个刺激标签，并且没有一个刺激标签被每个向量共享。因此，例如，Vector 2 看起来像这样：

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

和

Vector 3
Stim4    50
Stim3    10
Stim7    4
Stim11   22
...      ...

此外，每个向量都有可变数量的值......有些有 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，所以我相信这可以很简单地完成。

Answer 1

我假设您在 sheet1 中的 Vector 和 Stim 列表，而 sheet2 将显示您的矩阵。

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

此代码将完成这项工作：

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

如果有任何问题，欢迎提问！