Выполните макрос Test.
Функция UnPivot довольно часто бывает востребована.
Функция UnPivot довольно часто бывает востребована.
Код |
---|
Option Explicit ' arr - двумерный массив (соответствует диапазону ячеек). ' Возвращает массив с 3 столбцами: ' - заголовок строки ' - заголовок столбца ' - значение непустой ячейки на пересечении Function UnPivot(ByVal arr) Dim i As Long, j As Long, L1 As Long, L2 As Long, n As Long, reg As Long, res L1 = LBound(arr, 1) L2 = LBound(arr, 2) ' reg=1: считаем непустые ячейки ' reg=2: заполняем массив For reg = 1 To 2 If reg = 2 Then If n = 0 Then ' Нет непустых ячеек Exit Function Else ReDim res(1 To n, 1 To 3) n = 0 End If End If For i = L1 + 1 To UBound(arr, 1) For j = L2 + 1 To UBound(arr, 2) If Not IsEmpty(arr(i, j)) Then n = n + 1 If reg = 2 Then res(n, 1) = arr(i, L2) res(n, 2) = arr(L1, j) res(n, 3) = arr(i, j) End If End If Next j Next i Next reg UnPivot = res End Function Sub Test() Dim arr, res arr = ThisWorkbook.Worksheets(1).Range("A1").CurrentRegion.Value res = UnPivot(arr) With ThisWorkbook.Worksheets(2) .Cells.Delete .Range("A1").Resize(UBound(res, 1), UBound(res, 2)).FormulaLocal = res .Columns("A:C").AutoFit End With End Sub |
Владимир