excel - 循环在 Excel VBA 中添加大量矩阵

Question

我想编写一个宏，可以将 1000 个相同顺序的矩阵(50 行 * 30 列)堆叠在一张表中，并由两个空行分隔...我做了很多试验，但没有用...你能提供/推荐我吗处理此类问题的示例或书籍？谢谢

Answer 1

求和矩阵

将这两个代码复制到标准模块中(例如 Module1 )。

只有 Sub运行时，Function由 Sub 调用.

调整常量 Ant 包括工作簿 .

代码

Option Explicit

Sub sumUpMatrices()

    ' Source
    Const srcName As String = "Sheet1"
    Const srcFirstCell As String = "A1"
    ' Target
    Const tgtName As String = "Sheet2"
    Const tgtFirstCell As String = "A1"

    ' Matrices
    Const mRows As Long = 50
    Const mCols As Long = 30
    Const mCount As Long = 1000
    Const mEmpty As Long = 2

    ' Workbooks
    Dim src As Workbook: Set src = ThisWorkbook
    Dim tgt As Workbook: Set tgt = ThisWorkbook

    ' Write values from Source Range to Source Array.
    Dim Source As Variant
    Source = src.Worksheets(srcName).Range(srcFirstCell) _
      .Resize(mCount * (mRows + mEmpty) - mEmpty, mCols)

    ' Write values from Source Array to Target Array.
    Dim Target As Variant
    Target = sumUpVerticalMatrices(Source, mRows, mCols, mCount, mEmpty)

    ' Write values from Target Array to Target Range.
    tgt.Worksheets(tgtName).Range(tgtFirstCell).Resize(mRows, mCols) = Target

End Sub

Function sumUpVerticalMatrices(MatricesResult As Variant, _
                               ByVal RowsCount As Long, _
                               ByVal ColumnsCount As Long, _
                               ByVal MatricesCount As Long, _
                               ByVal Gap As Long) As Variant
    Dim rOff As Long: rOff = RowsCount + Gap
    Dim Result As Variant: ReDim Result(1 To RowsCount, 1 To ColumnsCount)
    Dim i As Long, j As Long, k As Long, CurrVal As Double
    For i = 1 To RowsCount
        For j = 1 To ColumnsCount
            CurrVal = 0
            For k = 1 To MatricesCount
                CurrVal = CurrVal + MatricesResult(i + (k - 1) * rOff, j)
            Next k
            Result(i, j) = CurrVal
        Next j
    Next i
    sumUpVerticalMatrices = Result
End Function

生成随机数据

Sub writeRandomVerticalMatrices()

    ' Worksheet
    Const wsName As String = "Sheet1"
    Const FirstCell As String = "A1"

    ' Matrices
    Const mRows As Long = 50
    Const mCols As Long = 30
    Const mCount As Long = 1000
    Const mEmpty As Long = 2

    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook

    ' Write data to Data Array.
    Dim Data As Variant
    Data = getRandomVerticalMatrices(mRows, mCols, mCount, mEmpty)

    ' Write from Data Array to Worksheet
    wb.Worksheets(wsName).Range(FirstCell) _
      .Resize(UBound(Data), UBound(Data, 2)).Value = Data

End Sub

Function getRandomVerticalMatrices(ByVal RowsCount As Long, _
                                   ByVal ColumnsCount As Long, _
                                   ByVal MatricesCount As Long, _
                                   ByVal Gap As Long) As Variant
    Dim rOff As Long: rOff = RowsCount + Gap
    Dim Result As Variant
    ReDim Result(1 To MatricesCount * rOff - Gap, 1 To ColumnsCount)
    Dim i As Long, j As Long, k As Long
    For i = 1 To RowsCount
        For j = 1 To ColumnsCount
            For k = 1 To MatricesCount
                Result(i + (k - 1) * rOff, j) = Int(500 * Rnd()) + 1
            Next k
        Next j
    Next i
    getRandomVerticalMatrices = Result
End Function