如何在vba中的变量数组上运行for循环？

Question

我正在 Excel 中处理 1066 x 592 矩阵（例如，M）。我想构建一个代码，将其适当地转换为 592 x 592 矩阵（比如 A）。 矩阵 M 是一个二进制矩阵（单元格值为 0 或 1）。 现在，假设对于 M 的 R1，单元格 (R1, C1), (R1, C6), (R1, C400) 和 (R1, C550) 为 1，其余为 0。然后，我想构建一个大小为 4（= 行中 1 的编号）的数组，它存储值（1、6、400、550）=（R1 中包含 1 的列号）。然后，我希望一个变量仅循环通过这 4 个值，这样，在矩阵 A 中，单元格 (1,6)、(1,400)、(1,550)、(6,400)、(6,550)、(400,550)、(6 ,1), (400,1), (550,1), (400,6), (550,6), (550,400) =（所有可能的长度为 2 的排列）将 1 添加到它们之前的值（最初为 0） .

我首先对所有行求和，因此每行的总和显示在第 1 列中。该行的 594 个。那么，

Sub ConnMat()

Dim i As Integer
Dim j As Integer
Dim r As Integer

For i = 2 To 1067

If Worksheets("Sheet3").Cells(i, 594).Value > 1 Then
Dim k As Integer
Dim k() as Integer
k = Cells(i, 594).Value    #no.of 1s in row i = length of array
For r = 1 To k
For j = 2 To 593
If Worksheets("Sheet3").Cells(i, j).Value = 1 Then
k(r) = j   #recording the column no containing 1 (=j) as the rth value of the array 
Next r
Next j




Worksheets("Sheet2").Cells(i, i).Value = Cells(i, j).Value + 1
End If
End If
Next i

我是新手，我还没有完成代码（无法继续，因为没有创建数组）。此外，我还查看了其他一些帖子，例如 Assigning an array value to a variable inside a for loop in vba ...但无法从他们那里获得价值。 请帮忙。

Answer 1

用一个小数据集测试 - 似乎工作正常：

Sub Tester()

    Const INPUT_ROWS As Long = 1066
    Const INPUT_COLS As Long = 592

    Dim r As Long, c As Long, c2 As Long, arr, sht As Worksheet
    Dim A(1 To INPUT_COLS, 1 To INPUT_COLS) As Long 'output array

    Set sht = Worksheets("Sheet1")

    'get the input values into a 2-D array
    arr = sht.Range("A1").Resize(INPUT_ROWS, INPUT_COLS).Value

    For r = 1 To INPUT_ROWS
        For c = 1 To INPUT_COLS
            If arr(r, c) = 1 Then
                'got a "1" - find others and combine pairs
                For c2 = (c + 1) To INPUT_COLS
                    If arr(r, c2) = 1 Then
                        'add pair to output array
                        A(c, c2) = A(c, c2) + 1
                        A(c2, c) = A(c2, c) + 1
                    End If
                Next c2
            End If
        Next c
    Next r

    'drop output array to worksheet
    sht.Range("A1").Offset(0, INPUT_COLS + 5).Resize( _
                       INPUT_COLS, INPUT_COLS).Value = A

End Sub

Answer 2

Sheet3 是输入（矩阵 M）表，Sheet2 是输出（结束矩阵 M）表。

Private Sub ReMatrixM()
    Dim arrInput() As Variant
    Dim arrSumOfMatrixAs(592, 592) As Long

    Dim Ones() As Integer 'An array keeping indexes of columns which iclude 1.
    Dim iOnes As Integer
    Dim RowM As Integer, ColM As Integer, iRowA As Integer, iColA As Integer

    Dim shtM As Worksheet, shtM2 As Worksheet, cell As Variant

    '1. Take the values included in the sheet in an array
    Set shtM = Worksheets("Sheet3")
    arrInput = shtM.Range("B2").Resize(1066, 592)

    '2. We find columns which includes 1s
    '3. We will use this column indexes by binary combinations to fint the coordinates where 1s are to be added.

    'Now we cycle all rows of array
    For RowM = 1 To 1066 'Rows

        ReDim Ones(0)
        iOnes = 0

        'Now we cycle all colums for each row of array
        For ColM = 1 To 592 'Columns

            If arrInput(RowM, ColM) = 1 Then
                iOnes = iOnes + 1
                ReDim Preserve Ones(iOnes)
                Ones(iOnes) = ColM 'We are taking indexes of columns which includes one.
            Else
               arrInput(RowM, ColM) = 0
            End If

        Next

        If UBound(Ones) > 0 Then

            'For every row of arrInput add the values say cells of Matrix A (arrSumOfMatrixAs).
            For iRowA = 1 To UBound(Ones)
                For iColA = 1 To UBound(Ones)
                    arrSumOfMatrixAs(Ones(iRowA), Ones(iColA)) = arrSumOfMatrixAs(Ones(iRowA), Ones(iColA)) + 1
                Next
            Next

        End If

    Next

    'Than we add the sum of "matrix A"s to arrInput
    For RowM = 1 To 592
        For ColM = 1 To 592
            arrInput(RowM, ColM) = arrInput(RowM, ColM) + arrSumOfMatrixAs(RowM, ColM)
        Next
    Next

    Set shtM2 = Worksheets("Sheet2")
    'We reflect the arrInput to the sheet (Matrix M) at the end.
    shtM2.Range("B2").Resize(1066, 592) = arrInput

End Sub

第一个代码首先将所有矩阵 A 的值相加，然后将它们添加到矩阵 M。但是如果您想逐行执行此操作，我的意思是如果在应用前一个矩阵 A 之后计算下一个矩阵 A，这是代码：

Private Sub ReMatrixM2()
    Dim arrInput() As Variant

    Dim Ones() As Integer 'An array keeping indexes of columns which iclude 1.
    Dim iOnes As Integer
    Dim RowM As Integer, ColM As Integer, iRowA As Integer, iColA As Integer

    Dim shtM As Worksheet, shtM2 As Worksheet, cell As Variant

    '1. Take the values included in the sheet in an array
    Set shtM = Worksheets("Sheet3")
    arrInput = shtM.Range("B2").Resize(1066, 592)

    '2. We find columns which includes 1s
    '3. We will use this column indexes by binary combinations to fint the coordinates where 1s are to be added.

    'Now we cycle all rows of array
    For RowM = 1 To 1066 'Rows

        ReDim Ones(0)
        iOnes = 0

        'Now we cycle all colums for each row of array
        For ColM = 1 To 592 'Columns

            If arrInput(RowM, ColM) > 0 Then 'See the difference
                iOnes = iOnes + 1
                ReDim Preserve Ones(iOnes)
                Ones(iOnes) = ColM 'We are taking indexes of columns which includes one.
            Else
               arrInput(RowM, ColM) = 0
            End If

        Next

        If UBound(Ones) > 0 Then

            'For every row of arrInput add the values in -say- cells of Matrix A to arrInput.
            For iRowA = 1 To UBound(Ones)
                For iColA = 1 To UBound(Ones)
                    arrInput(Ones(iRowA), Ones(iColA)) = arrInput(Ones(iRowA), Ones(iColA)) + 1
                Next
            Next

        End If

    Next

    Set shtM2 = Worksheets("Sheet2")
    'We reflect the arrInput to the sheet (Matrix M) at the end.
    shtM2.Range("B2").Resize(1066, 592) = arrInput

End Sub

Answer 3

感谢@kitap mitap，@Tim Williams 我在学！ :) 将我的答案分为两个单独的步骤，效果很好。 第 1 步：

Sub ComAct()


Dim i As Integer
Dim j As Integer
Dim r As Integer
Dim p As Integer
'Dim v() As Integer
Dim k As Integer


For i = 2 To 1067
p = 0
 If Worksheets("Sheet3").Cells(i, 594).Value > 1 Then
  k = Cells(i, 8).Value
  For j = 2 To 593
   If Worksheets("Sheet3").Cells(i, j).Value = 1 Then
    p = p + 1
    Worksheets("Sheet4").Cells(i - 1, p).Value = j
   End If
  Next j
 End If
Next i
End Sub

第 2 步：

Sub ConnMat()
Worksheets("Sheet2").Range("B2:VU593").Value = 0

Dim i As Integer
Dim v As Integer
Dim j As Integer
Dim k As Integer

For i = 1 To 1067
 v = Worksheets("Sheet4").Cells(i, 30).Value
  If v > 1 Then
   For j = 1 To v
   For k = 1 To v
   If j <> k Then
   Worksheets("Sheet2").Cells(Worksheets("Sheet4").Cells(i, j).Value, Worksheets("Sheet4").Cells(i, k).Value).Value = Worksheets("Sheet2").Cells(Worksheets("Sheet4").Cells(i, j).Value, Worksheets("Sheet4").Cells(i, k).Value).Value + 1
   End If
   Next k
   Next j
   End If
   Next i
End Sub