Добавление массивов вместе (в VBA) для вывода

Question

Могу ли я добавить массивы вместе для вывода?

Код совпадает с заголовками и возвращает значения в различные массивы.когда я пытаюсь вывести свои массивы и добавить значения вместе, я получаю

несоответствие типов

в строке

.Range("B" & lastrow + 1 & ":" & "H" & lastrow + 1).Value = Application.Transpose(R) + Application.Transpose(M) + Application.Transpose(O) + Application.Transpose(Q)

в следующем коде:

Const FirstMatch As Boolean = True
Dim SR As Variant
Dim OAS As Variant
Dim iSR As Integer
Dim iOAS As Integer
Dim R As Variant
Dim M As Variant
Dim O As Variant
Dim Q As Variant
Dim headers As Variant
Dim iheaders As Integer

SR = Worksheets("Sheet A").Range("D3:J7").Value  ' Array for CS01 Data
OAS = Worksheets("Sheet A").Range("D28:J35").Value 'Array for MBS Data
headers = Worksheets("Sheet B").Range("B1:H1").Value

With Worksheets("Sheet B")
    ReDim R(1 To UBound(SR, 2), 1 To 1)
    ReDim M(1 To UBound(SR, 2), 1 To 1)
    ReDim O(1 To UBound(SR, 2), 1 To 1)
    ReDim Q(1 To UBound(SR, 2), 1 To 1)

    For iheaders = 1 To UBound(headers, 2)
        For iSR = 1 To UBound(SR, 2)
            If headers(1, iheaders) = SR(1, iSR) Then
                R(iSR, 1) = SR(5, iSR)
                If FirstMatch Then
                    Exit For
                End If
            End If
        Next

        For iOAS = 1 To UBound(OAS, 2)
            If headers(1, iheaders) = OAS(1, iOAS) Then
                M(iOAS, 1) = OAS(6, iOAS)
                O(iOAS, 1) = OAS(7, iOAS)
                Q(iOAS, 1) = OAS(8, iOAS)
                If FirstMatch Then
                    Exit For
                End If
            End If
        Next
    Next

    .Range("B" & lastrow + 1 & ":" & "H" & lastrow + 1).Value = Application.Transpose(R) + Application.Transpose(M) + Application.Transpose(O) + Application.Transpose(Q)
End With

Answer 1

Исходный код, размещенный в вопросе, использует слишком много для… next и массивов, предлагает использовать функцию Match, чтобы определить положение поля и суммировать требуемые значения по полю, перед добавлением их в массив, а затем опубликовать полученный массив.

Требования, как я понимаю проблему:

Чтобы добавить значения в строке 5 из диапазона D3:J7 и значения в строках 6, 7 и 8 из диапазона D28:J35 в листе Sheet A, поскольку они соответствуют полям в диапазоне B1:H1 на листе Sheet B, используя первую строку каждого диапазона, чтобы определить положение поля относительно диапазона B1:H1 на листе Sheet B.Затем, чтобы опубликовать результирующие значения для каждого поля в первой пустой строке ниже диапазона B1:H1 на листе Sheet B.

Код ниже использует функцию листа Match вместо того, чтобы идентифицировать позиции полей в каждом диапазонезацикливание каждого диапазона Затем, после определения положения поля в каждом диапазоне, добавьте соответствующие значения в выходной массив

Образец DATA before:

Sub TEST()
Dim aOutput As Variant
Dim aHdr As Variant, aSR As Variant, aOAS As Variant
Dim bHdr As Byte, bSR As Byte, bOAS As Byte
Dim lastrow

    lastrow = 1     'Value assigned for test purpose

    Rem Set Arrays
    With ThisWorkbook
        aSR = .Worksheets("Sheet A").Range("D3:J7").Value     ' Array for CS01 Data
        aOAS = .Worksheets("Sheet A").Range("D28:J35").Value  ' Array for MBS Data
        aHdr = Worksheets("Sheet B").Range("B1:H1").Value
    End With

    Rem Redimensioning Header Array
    aHdr = WorksheetFunction.Transpose(aHdr)
    aHdr = WorksheetFunction.Transpose(aHdr)

    Rem Create Output Array
    aOutput = aHdr

    Rem Fill Output Array
    For bHdr = 1 To UBound(aHdr)

        Rem Initiate Variables
        bSR = 0
        bOAS = 0
        aOutput(bHdr) = 0

        With WorksheetFunction

            Rem Get Field Position
            On Error Resume Next
            bSR = .Match(aHdr(bHdr), .Index(aSR, 1, 0), 0)
            bOAS = .Match(aHdr(bHdr), .Index(aOAS, 1, 0), 0)
            On Error GoTo 0

            Rem Add Field Values To Ouput Array
            If bSR <> 0 Then aOutput(bHdr) = aSR(5, bSR)
            If bOAS <> 0 Then aOutput(bHdr) = aOutput(bHdr) _
                + aOAS(6, bOAS) + aOAS(7, bOAS) + aOAS(8, bOAS)

    End With: Next

    Rem Post Ouput Array
    ThisWorkbook.Worksheets("Sheet B").Cells(1 + lastrow, 2) _
        .Resize(1, UBound(aOutput)).Value2 = aOutput

    End Sub

Результат:

Поэтому нет необходимости добавлять несколько массивов, поскольку создается только один массив.

Обратите внимание, что в исходном коде эти строки:

R(iSR, 1) = SR(5, iSR) 
M(iOAS, 1) = OAS(6, iOAS) 
O(iOAS, 1) = OAS(7, iOAS) 
Q(iOAS, 1) = OAS(8, iOAS) 

Должно было быть:

R(iheaders, 1) = SR(5, iSR) 
M(iheaders, 1) = OAS(6, iOAS) 
O(iheaders, 1) = OAS(7, iOAS) 
Q(iheaders, 1) = OAS(8, iOAS) 

Answer 2

Подход с умножением матрицы

Чтобы сложить 2 одномерных массива, вы можете выполнить следующую математическую уловку и умножить массив из 4 массивов на Array(1, 1, 1, 1) с помощью WorksheetFunction.Метод MMult , который приводит к сумме этих 4 массивов (из-за правил умножения матриц):

Option Explicit

Public Sub AddArrays()
    Dim arr1 As Variant, arr2 As Variant, arr3 As Variant, arr4 As Variant
    arr1 = Array(1, 3, 5, 5)
    arr2 = Array(4, 0, 9, 1)
    arr3 = Array(1, 2, 3, 4)
    arr4 = Array(4, 3, 2, 1)
    'result     10, 8, 19, 11

    Dim MultArr As Variant
    MultArr = Array(1, 1, 1, 1)  'a 1 for every arr variable that you sum (4 arrays = 4 ones)

    Dim ResultArr As Variant
    ResultArr = Application.WorksheetFunction.MMult(MultArr, Array(arr1, arr2, arr3, arr4))

    'just an output example:
    Debug.Print Join(ResultArr, ", ")
End Sub

Из-за правил умножения матриц это то, как он умножает матрицуMultArr с матрицей, состоящей из arr1 … arr4, что соответствует результату добавления arr1 … arr4:

Так как в вашем вопросе2-мерные массивы ReDim R(1 To UBound(SR, 2), 1 To 1) почти одномерны, их можно уменьшить до 1D-массива ReDim R(1 To UBound(SR, 2)), заполненного как R(iSR) = SR(5, iSR), и вы можете легко использовать этот трюк выше для суммирования их:

.Range("B" & lastrow + 1 & ":" & "H" & lastrow + 1).Value = Application.WorksheetFunction.MMult(Array(1, 1, 1, 1), Array(R, M, O, Q))

Подход с циклом

Поскольку Крис Нейлсен отметил, что показанный выше подход примерно в 8 раз медленнее, чем цикл, я предлагаю следующее:

Поскольку в вашем вопросе двумерный массивs ReDim R(1 To UBound(SR, 2), 1 To 1) почти одномерны, их можно уменьшить до одномерного массива, который легче обрабатывать ReDim R(1 To UBound(SR, 2)) заполненный как R(iSR) = SR(5, iSR)

И вы можете суммировать их с помощью цикла

Dim RestultArr As Variant
ReDim ResultArr(1 To UBound(SR, 2))

Dim i As Long
For i = LBound(ResultArr) To UBound(ResultArr)
    ResultArr(i) = R(i) + M(i) + O(i) + Q(i)
Next i

и напишите в свой диапазон

.Range("B" & lastrow + 1 & ":" & "H" & lastrow + 1).Value = ResultArr

Answer 3

Еще один путь, ведущий в Рим ...

Просто ради искусства и в дополнение к действующим решениям, приведенным выше, я демонстрирую способ как патч требуемые части массива объединяются в один слой (вместо создания нескольких массивов) с использованием расширенных функций фильтрации функции Application.Index (см. Раздел 1b).

Полученный новый вариантный массив v записывается обратно в 'Sheet B' (см. Раздел 2).

Кроме того, я показываю несколько примеров, чтобы получить столбецили суммы строк, а также итоги (см. раздел 3).

Пример кода

Я предполагаю столбцы в блоках данныхпринадлежат к одинаковым категориям.

Option Explicit         ' declaration head of your code module

Sub AddDataBlocks()
' [1a] create 2-dim data field array (1-based)
  Dim v
  v = ThisWorkbook.Worksheets("Sheet A").Range("D3:J35").Value2
' [1b] filter rows to be maintained (omitting title row)
  Dim MyRows(): MyRows = Array(5, 31, 32, 33)
  v = Application.Transpose(Application.Index(v, MyRows, Evaluate("row(1:" & UBound(v, 2) & ")")))

' [2]  write new array back to sheet B
  Dim lastrow&: lastrow = 1
  ThisWorkbook.Worksheets("Sheet B").Range("B" & lastrow + 1).Resize(UBound(v), UBound(v, 2)) = v

' ~~> Some arithmetics in examples
' [3a] get total sum
  Dim total#, i&, j&
  For i = LBound(v) To UBound(v)
      For j = LBound(v, 2) To UBound(v, 2)
          total = total + v(i, j)
      Next j
  Next i
  Debug.Print "Total = " & total
' [3b] display a row sum, e.g. 2nd row (no iM)
  Const iR = 1, iM = 2, iO = 3, iQ = 4
  Debug.Print "M = " & WorksheetFunction.Sum(Application.Transpose(Application.Index(v, iM, 0)))
' [3c] display a column sum, e.g. 3rd column
  Debug.Print "3rd column added = " & WorksheetFunction.Sum(Application.Transpose(Application.Index(v, 0, 3)))

End Sub

Answer 4

Нет, VBA не поддерживает векторные операции над массивами.Вам просто нужно перебрать все значения в ваших массивах, сложить их вместе в новый выходной массив, а затем установить значение вашего диапазона в новый массив.