0

このタイトルが十分に説明的かどうかはわかりません。

したがって、基本的には、それぞれ数百の値を含む多数のベクトル (約 50 個) があります。各ベクトルには番号が付けられており、次のようになります。

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

つまり、特定の刺激ラベル (StimX) に関連付けられた番号があります。ただし、各ベクトルには一意の刺激ラベルのセットが設定されています。一部の刺激ラベルは複数のベクトル間で共有されますが、各ベクトルにすべての刺激ラベルが含まれているわけではなく、1 つの刺激ラベルがすべてのベクトルで共有されるわけではありません。たとえば、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についてよく知らないので、これはかなり簡単に実行できると確信しています。

4

1 に答える 1

1

シート 1 の Vector と Stim のリストとシート 2 にマトリックスが表示されると仮定しました。

列 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

ご不明な点がございましたら、お気軽にお問い合わせください。

于 2013-03-12T14:54:04.327 に答える