MyTetra Share
Делитесь знаниями!
Разбиение строк двумерного массива - по одной строке для каждого значения
16.03.2019
23:43
Текстовые метки: Обработка массивов,Обработка таблиц,Массивы
Раздел: !Закладки - VBA - Array

Разбиение строк двумерного массива - по одной строке для каждого значения

Если у вас есть таблица Excel, в которой, в определённом столбце, через запятую перечислены значения (или диапазоны значений), а вы хотите получить аналогичную таблицу, но чтобы в каждой строке было только одно значение, - то вам на помощь придёт функция ExtendArray.

(пример работы функции можно увидеть на прикреплённом изображении)

В своей работе ExtendArray использует функцию ArrayOfValues и функцию TransposeArray
(которые надо также добавить в код, чтобы функция работала)

Function ExtendArray(ByVal arr, ByVal ColumnForExtend As Long) As Variant

' принимает в качестве параметров:

' двумерный массив arr, и номер столбца ColumnForExtend, содержащего список значений

' Возвращает двумерный массив (возможно, с большим количеством строк),

' в котором все строки содержат в столбце ColumnForExtend только одно значение

' индексы всех массивов начинаются с единицы (Option Base 1)


ColumnsCount% = UBound(arr, 2) - LBound(arr, 2) + 1

If ColumnForExtend > ColumnsCount% Or ColumnForExtend < 1 Then

MsgBox "В массиве нет столбца с номером " & ColumnForExtend, vbCritical, "Ошибка": End

End If

 

' формируем временный столбец из 1 столбца

ReDim tmpArr(1 To ColumnsCount%, 1 To 1)

 

For i = LBound(arr) To UBound(arr) ' перебираем все строки исходного массива

' перебираем все значения в заданном столбце

For Each v In ArrayOfValues(arr(i, ColumnForExtend))

' формируем новую запись (столбец) во временном массиве

For j = LBound(arr, 2) To UBound(arr, 2)

tmpArr(j, UBound(tmpArr, 2)) = arr(i, j)

Next j

' вместо списка значений поставляем очередное значение

tmpArr(ColumnForExtend, UBound(tmpArr, 2)) = v

' добавляем дополнительный столбец к временному массиву

ReDim Preserve tmpArr(1 To ColumnsCount%, 1 To UBound(tmpArr, 2) + 1)

Next v

Next i

' удаляем лишний столбец

On Error Resume Next: ReDim Preserve tmpArr(1 To ColumnsCount%, 1 To UBound(tmpArr, 2) - 1)

' транспонируем временный массив, и возвращаем результат

ExtendArray = TransposeArray(tmpArr)

End Function

Функция нашла применение в программе выгрузки тарифов в XML - там вы можете посмотреть её в работе.

Вложение

Размер

Загрузки

Последняя загрузка

ExtendArray.xls

34.5 КБ

120

1 день 23 часа назад

  • 10123 просмотра
Прикрепленные файлы:
Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования