Как создать 3-мерный массив, а затем вытащить информацию 1 измерение за раз?

Question

Я хотел бы взять наборы данных с листа 1 и заполнить значения таблицы на листе 2. Я считаю, что использование многомерного массива является оптимальным способом для достижения этой цели.

Лист 1 настроен так: Столбец A = "Даты", Столбец C = "SNs", Столбец E = "M0s" и Столбец F = "HNs".

Оператор вводит значение M0, и если a (" E "). Строка имеет это значение, я хочу, чтобы SN, HN и Date этой строки были введены в Лист 2. Тот факт, что две строки имеют одинаковое M0, не означает, что они имеют одинаковые SN, HN или Date. Я хотел бы, чтобы значения каждой строки сохранялись отдельно, следовательно, это многомерный массив (в данном случае 3-мерный).

Приведенный ниже код является моей успешной попыткой сохранить все SN в одномерном массиве (на основе введенного M0) и затем ввести эти значения в лист 2.

        Sub FillSheet2()
        Dim varSNarray As Variant
        Dim M0cell As Range
        Dim SNcell As Long  'could be substituted with Variant or String

        ReDim varSNarray(0)
        For Each M0cell In ws.Range("E7:E200000").Cells
            If M0cell.Value <> vbNullString Then
                If M0cell.Value = varPrintM0 Then
                    SNcell = ws.Range("C" & M0cell.Row).Value
                    varSNarray(UBound(varSNarray)) = SNcell
                    ReDim Preserve varSNarray(UBound(varSNarray) + 1) As Variant

                End If
            End If
        Next M0cell

        ReDim Preserve varSNarray(UBound(varSNarray) - 1)

        Dim i As Long
        For i = LBound(varSNarray) To UBound(varSNarray)

            Dim ws2range As Range
            Dim ws2SNcellnum As Long

            If i > 149 Then
                Set ws2range = ws2.Range("AN6:AN55")
                    ws2SNcellnum = i - 144
                    ws2.Range("AN" & ws2SNcellnum).Value = varSNarray(i)

            ElseIf i > 99 Then
                Set ws2range = ws2.Range("AA6:AA55")
                    ws2SNcellnum = i - 94
                    ws2.Range("AA" & ws2SNcellnum).Value = varSNarray(i)

            ElseIf i > 49 Then
                Set ws2range = ws2.Range("N6:N55")
                    ws2SNcellnum = i - 44
                    ws2.Range("N" & ws2SNcellnum).Value = varSNarray(i)

            Else
                Set ws2range = ws2.Range("A6:A55")
                    ws2SNcellnum = i + 6
                    ws2.Range("A" & ws2SNcellnum).Value = varSNarray(i)
            End If


        Next i
 End Sub

Я хотел бы добавьте HN и дату вместе с SN, когда эта подпрограмма работает. Я не знаю, как увеличить массив, чтобы учесть хранение HN и Date. Ниже я представляю, как это будет выглядеть. Тем не менее, я не могу успешно создать свой массив. Я уверен, что это как-то связано с моими настройками переменных.

            Dim varSNarray As Variant
            Dim M0cell As Range
            Dim SNcell As Long
            Dim HNcell As Long
            Dim Datecell As Long

            ReDim varSNarray(0, 0, 0)
            For Each M0cell In ws.Range("E7:E200000").Cells
                If M0cell.Value <> vbNullString Then
                    If M0cell.Value = varPrintM0 Then
                    SNcell = ws.Range("C" & M0cell.Row).Value
                        varSNarray(UBound(varSNarray), HNcell, Datecell) = SNcell
                        varSNarray(SNcell, UBound(varSNarray), Datecell) = HNcell 'Script out of range error
                        varSNarray(SNcell, HNcell, UBound(varSNarray)) = Datecell

                        ReDim Preserve varSNarray(UBound(varSNarray) + 1, UBound(varSNarray) + 1, UBound(varSNarray) + 1) As Variant

                    End If


                End If
            Next M0cell

            ReDim Preserve varSNarray(UBound(varSNarray) - 1)

            Dim i As Long
            For i = LBound(varSNarray) To UBound(varSNarray)

                Dim ws2range As Range
                Dim ws2SNcellnum As Long

                If i > 149 Then
                    Set ws2range = ws2.Range("AN6:AN55")
                        ws2SNcellnum = i - 144
                        ws2.Range("AN" & ws2SNcellnum).Value = varSNarray(i)
                        ws2.Range("AN" & ws2SNcellnum).Value = varSNarray(HNcell)
                        ws2.Range("AN" & ws2SNcellnum).Value = varSNarray(Datecell)
                 ''''  
                 Removed this section has its the same as above
                 ''''
                    Set ws2range = ws2.Range("A6:A55")
                        ws2SNcellnum = i + 6
                        ws2.Range("A" & ws2SNcellnum).Value = varSNarray(i)
                        ws2.Range("A" & ws2SNcellnum).Value = varSNarray(HNcell)
                        ws2.Range("A" & ws2SNcellnum).Value = varSNarray(Datecell)

                End If


            Next i

Как сохранить данные в 3-мерном массиве, а затем успешно извлечь 1 измерение из массива за раз?

Answer 1

Я не думаю, что здесь нужен массив, просто запишите записи на лист 2, как только они найдены. Например,

Option Explicit
Sub FillSheet2()

    Const COL_DATE = "A"
    Const COL_SN = "C"
    Const COL_M0 = "E"
    Const COL_HN = "F"
    Const START_ROW = 7

    ' target sheet
    Const TARGET_START_ROW = 5
    Const TARGET_START_COL = 1 'A
    Const COL_REPEAT = 13 ' N, AA, AN
    Const MAX_ROWS = 50

    Dim wb As Workbook, wsSource As Worksheet, wsTarget As Worksheet
    Set wb = ThisWorkbook
    Set wsSource = wb.Sheets("Sheet1")
    Set wsTarget = wb.Sheets("Sheet2")
    wsTarget.Cells.Clear

    Dim iRow As Integer, iLastRow As Integer, iCount As Integer
    Dim iTargetRow As Integer, iTargetCol As Integer, sM0 As String
    Dim varPrintM0 As String

    iTargetCol = TARGET_START_COL
    iTargetRow = TARGET_START_ROW

    varPrintM0 = "Test4"

    iCount = 0
    iLastRow = wsSource.Range(COL_M0 & Rows.Count).End(xlUp).Row

    ' ----------    
    With wsSource
        For iRow = START_ROW To iLastRow
            sM0 = .Range(COL_M0 & iRow)
            If sM0 = varPrintM0 Then

                With wsTarget.Cells(iTargetRow, iTargetCol)
                  .Offset(0, 0) = wsSource.Range(COL_SN & iRow).Value
                  .Offset(0, 1) = wsSource.Range(COL_HN & iRow).Value
                  .Offset(0, 2) = wsSource.Range(COL_DATE & iRow).Value
                End With
                iTargetRow = iTargetRow + 1

                If iTargetRow >= MAX_ROWS + TARGET_START_ROW Then
                  iTargetCol = iTargetCol + COL_REPEAT
                  iTargetRow = TARGET_START_ROW
                End If
                iCount = iCount + 1
            End If
        Next
    End With
    MsgBox iCount & " rows copied", vbInformation, "Finished"        
    ' --------

End Sub

Если вы хотите использовать массив, замените код между строками ------ выше на этот

    Dim ar(5, 50, 3) As Variant ' max of 5 blocks of 50 records
    Dim t As Integer, r As Long
    t = 1: r = 1

    ' fill array
    With wsSource
        For iRow = START_ROW To iLastRow
            sM0 = .Range(COL_M0 & iRow)
            If sM0 = varPrintM0 Then

                With wsTarget.Cells(iTargetRow, iTargetCol)
                    ar(t, r, 0) = sM0
                    ar(t, r, 1) = wsSource.Range(COL_SN & iRow).Value
                    ar(t, r, 2) = wsSource.Range(COL_HN & iRow).Value
                    ar(t, r, 3) = wsSource.Range(COL_DATE & iRow).Value
                End With

                r = r + 1
                If r > MAX_ROWS Then
                    r = 1
                    t = t + 1
                End If
                iCount = iCount + 1
            End If
        Next
    End With

    ' output array
    Dim iLastTable As Long, c As Long
    iLastTable = t
    For t = 1 To iLastTable
        For r = 1 To 50
            c = 1 + COL_REPEAT * (t - 1)
            With wsTarget.Cells(r + 4, c)
                .Offset(0, 0) = ar(t, r, 1)
                .Offset(0, 1) = ar(t, r, 2)
                .Offset(0, 2) = ar(t, r, 3)
            End With
        Next r
    Next t
    MsgBox iCount & " rows copied using Array", vbInformation, "Finished"