Вот альтернативный пример, который работает с использованием массивов на основе памяти для скорости, а также помогает с транспозицией и правильным размером данных.
Этот алгоритм предполагает:
- У вас всегда будут наборы данных, начинающиеся с
_1 - Номера наборов данных всегда увеличиваются последовательно, например,
_1, _2, _3 и c - Всегда будет одинаковое количество «групп» данных, поскольку есть наборы данных.
Мои данные для примера выглядят так:
Сначала я перемещаю данные в массив на основе памяти
Dim inData As Variant
inData = Sheet1.UsedRange.Value
Затем, основываясь на этих предположениях, для правильной сортировки результатов вам необходимо выяснить, как много наборов данных у вас есть. Поэтому я создал эту функцию, которая использует функцию Split для получения числового значения после подчеркивания:
Private Function DetermineNumberOfSets(ByRef data As Variant) As Long
'--- runs through the labels in the first column and separates
' the number value following the underscore to find the maximum
' count of data sets
Dim max As Long
Dim i As Long
For i = LBound(data, 1) To UBound(data, 1)
Dim tokens As Variant
tokens = Split(data(i, 1), "_")
If UBound(tokens) > 0 Then
If max < tokens(1) Then max = tokens(1)
End If
Next i
DetermineNumberOfSets = max
End Function
Итак, основная подпрограмма вызывает
Dim dataSetCount As Long
Dim columnCount As Long
dataSetCount = DetermineNumberOfSets(inData)
'--- this determines how many columns are in the output data
Dim allSetsCount As Long
allSetsCount = dataSetCount * dataSetCount
Путем вычисления allSetsCount таким образом, вы фактически пропускаете все пустые строки во входных данных.
Теперь создайте массив для хранения всех транспонированных данных
'--- this determines how many rows are in the output data
Dim maxDataPointsCount As Long
maxDataPointsCount = UBound(inData, 2)
Dim outData As Variant
ReDim outData(1 To maxDataPointsCount, 1 To allSetsCount)
И, наконец, просмотрите ваши данные в собирать наборы данных по порядку и переносить данные в выходной массив.
Dim setNumber As Long
For setNumber = 1 To dataSetCount
'--- run through the data and pick out the data for this set
Dim i As Long
For i = LBound(inData, 1) To UBound(inData, 1)
Dim thisSetNumber As Long
thisSetNumber = WhatsTheDataSet(inData(i, 1))
If thisSetNumber = setNumber Then
'--- copy this set to the output
Dim j As Long
For j = 1 To maxDataPointsCount
outData(j, outputColumn) = inData(i, j)
Next j
outputColumn = outputColumn + 1
End If
Next i
Next setNumber
Вот весь модуль для всего кода
Option Explicit
Option Base 0
Public Sub CollateData()
Dim inData As Variant
inData = Sheet1.UsedRange.Value
Dim dataSetCount As Long
Dim columnCount As Long
dataSetCount = DetermineNumberOfSets(inData)
'--- this determines how many columns are in the output data
Dim allSetsCount As Long
allSetsCount = dataSetCount * dataSetCount
'--- this determines how many rows are in the output data
Dim maxDataPointsCount As Long
maxDataPointsCount = UBound(inData, 2)
Dim outData As Variant
ReDim outData(1 To maxDataPointsCount, 1 To allSetsCount)
Dim outputColumn As Long
outputColumn = 1
Dim setNumber As Long
For setNumber = 1 To dataSetCount
'--- run through the data and pick out the data for this set
Dim i As Long
For i = LBound(inData, 1) To UBound(inData, 1)
Dim thisSetNumber As Long
thisSetNumber = WhatsTheDataSet(inData(i, 1))
If thisSetNumber = setNumber Then
'--- copy this set to the output
Dim j As Long
For j = 1 To maxDataPointsCount
outData(j, outputColumn) = inData(i, j)
Next j
outputColumn = outputColumn + 1
End If
Next i
Next setNumber
Dim outRange As Range
Set outRange = Sheet2.Range("A1").Resize(UBound(outData, 1), UBound(outData, 2))
outRange.Value = outData
End Sub
Private Function DetermineNumberOfSets(ByRef data As Variant) As Long
'--- runs through the labels in the first column and separates
' the number value following the underscore to find the maximum
' count of data sets
Dim max As Long
Dim i As Long
For i = LBound(data, 1) To UBound(data, 1)
Dim tokens As Variant
tokens = Split(data(i, 1), "_")
If UBound(tokens) > 0 Then
If max < tokens(1) Then max = tokens(1)
End If
Next i
DetermineNumberOfSets = max
End Function
Private Function WhatsTheDataSet(ByVal label As String) As Long
Dim tokens As Variant
tokens = Split(label, "_")
If UBound(tokens) > 0 Then
WhatsTheDataSet = tokens(1)
End If
End Function