如何创建一个三维数组，然后一次提取一维信息

Question

我想从表1中获取数据集，并在表2中填写表值。我相信使用多维数组是实现这一目标的最佳方式。

工作表1设置如下：A列="日期"，C列="SN"，E列="M0s"，F列="HNs"。

操作员输入M0值，如果("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和Date以及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

如何将数据存储到三维数组中，然后一次从数组中成功提取一维？

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"