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

如果您有任何疑问，请询问！

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

1 个答案: