Массив против диапазона
Option Explicit
'START ****************************************************************** START'
' Title: Search and Extract Single Criteria '
' Purpose: In a specified Data Worksheet, each non-empty row contains '
' an unknown number of consecutive data sets of a specified '
' size (columns). '
' By looping through each row of Data Worksheet, copies each '
' data set to another specified Report Worksheet one below '
' another, starting from a specified cell range. '
'******************************************************************************'
Sub search_and_extract_singlecriteria()
' 10s for 1280 cols and 3000 rows = 480000 rows in Report Sheet
Const Noc As Long = 8 ' Size of Data Set (Number of Columns)
' = Number of Columns in Report Array
Const strRR As String = "B2" ' Report First Cell Range Address
Dim wsD As Worksheet: Set wsD = Sheet1 ' Data Sheet
Dim wsR As Worksheet: Set wsR = Sheet2 ' Report Sheet
Dim rng As Range ' Last Non-Empty Cell in the Last Non-Empty Row,
' Non-Empty Range (both in Data Sheet)
Dim vntD As Variant ' Data Array (2D 1-based)
Dim vntC As Variant ' Count Array (1D 1-based)
Dim vntR As Variant ' Report Array (2D 1-based)
Dim Nor As Long ' Number of Data Sets
' = Number of Rows in Report Array
Dim i As Long ' Data/Count Array Rows Counter
Dim j As Long ' Data Array Columns Counter
Dim k As Long ' Count Array Values Counter
Dim m As Long ' Report Array Rows Counter
' IN DATA SHEET
' Note: It is assumed that Data Sheet contains ONLY Data Sets.
' By defining the Last Non-Empty Cell in the Last Non-Empty Row
' using the Find method, check if the sheet is not empty.
Set rng = wsD.Cells.Find("*", wsD.Cells(wsD.Rows.Count, wsD.Columns.Count), _
xlFormulas, , xlByRows)
If rng Is Nothing Then Exit Sub
' Define Non-Empty Range on Data Sheet.
Set rng = wsD.Range(wsD.Cells(rng.Row, wsD.Cells.Find("*", _
wsD.Cells(wsD.Rows.Count, wsD.Columns.Count), , , xlByColumns).Column), _
wsD.Cells(wsD.Cells.Find("*", , , , xlByRows, xlPrevious).Row, _
wsD.Cells.Find("*", , , , xlByColumns, xlPrevious).Column))
' Write values of Non-Empty Range on Data Sheet to Data Array.
vntD = rng
' Release object variables. Necessary data is in Data Array (vntD).
Set rng = Nothing
Set wsD = Nothing
' IN ARRAYS
' Task: Calculate Number of Rows in Report Array and populate Count Array.
' Resize Count Array (vntC) to number of rows of Data Array (vntD).
ReDim vntC(1 To UBound(vntD))
' Loop through rows (1st dimension) of Data Array (vntD).
For i = 1 To UBound(vntD)
' Loop through every Noc-th column (2nd dimension) of Data Array (vntD).
For j = 1 To UBound(vntD, 2) Step Noc
' Check if value of current element in Data Array (vntD) is <> "".
If vntD(i, j) <> "" Then
' Value of current element in Data Array (vntD) is <> "".
' Increase Count Array Value (Count of Data Sets in current row
' of Data Array).
k = k + 1
' Increase Number of Rows in Report Array
' (Total Count of Data Sets).
Nor = Nor + 1
Else
' Value of current element in Data Array (vntD) is = "".
' The following will leave the current element in Count Array
' empty, i.e. 0 which becomes obvious only later in:
' "If vntC(i) > 0 Then...".
Exit For
End If
Next
' Write current Count Array Value (k) to current element
' of Count Array (vntC).
' Note: The i-th row in Data Array contains k Data Sets.
vntC(i) = k
' Reset Count Array Values Counter.
k = 0
Next
' Remarks: Count Array (vntC) has the same number of elemnts
' as Data Array (vntD) has rows. Each value in Count Array (vntC)
' respresents the number of Data Sets per row of Data Array (vntD).
' The implementation of Count Array (vntC) makes it possible
' to write the last loop as a For Next loop:
' "For j = (k - 1) * Noc + 1 To (k - 1) * Noc + Noc...",
' without checking if there are "" values, because it has
' already been checked previously in:
' "If vntD(i, j) <> "" Then)...".
' Task: Define and populate Report Array.
' Resize Report Array (vntR) to rows defined by Number of Data Sets (Nor)
' and columns specified by (Column) Size of Data Set (Noc).
ReDim vntR(1 To Nor, 1 To Noc)
' Loop through rows (1st dimension) of Data Array (vntD).
For i = 1 To UBound(vntD)
' Check if the value in the same row (i) in Count Array (vntC) is > 0.
If vntC(i) > 0 Then
' Value in the same row (i) in Count Array (vntC) is > 0.
' Loop through Data Sets from Data Array.
For k = 1 To vntC(i)
' Increase Report Array Rows Counter (m).
m = m + 1
' Loop through columns (j) of current Data Set.
For j = (k - 1) * Noc + 1 To (k - 1) * Noc + Noc
' Write value of current element of Data Array (Set) to
' current element of Report Array.
vntR(m, j - (k - 1) * Noc) = vntD(i, j)
Next
Next
'Else
' Value in the same row (i) in Count Array (vntC) is NOT > 0 i.e.
' skipping (No Data Set in) current row of Data Array (vntD).
End If
Next
' IN REPORT SHEET
' Copy values of Report Array to Report Range defined by the specified
' Report First Cell Range Address (strRR) in specified Report Sheet (wsR)
' and the size (rows and columns) of Report Array (vntR).
wsR.Range(strRR).Resize(UBound(vntR), UBound(vntR, 2)) = vntR
End Sub
'END ********************************************************************** END'