Коллеги, добрый день. Помогите, пожалуйста, макросом, который транспонирует данные в столбцах от "B" до "D" в связке с данными в столбце "А". Т.е. точно так же, как это делается с помощью Unpivot other columns в PowerQuery, но только макросом)
Файл-пример прилагаю. Заранее огромное человечекое спасибо!
Option Explicit
Sub jjj()
Dim arrDebitor(), arrHeads(), arrData(), i&, j&, n&, lRowsTotal&, lColsTotal&, lCnt&, arrNewHeads(), arrResult()
arrDebitor = [A5:A28].Value
arrHeads = [B4:D4].Value
With Intersect([A5:A28].EntireRow, [B4:D4].EntireColumn)
arrData = .Value
lRowsTotal = .Rows.CountLarge
n = .Columns.CountLarge
End With 'Intersect([A5:A28].EntireRow, [B4:D4].EntireColumn)
arrNewHeads = VBA.Array("Дебитор", "Attribute", "Value")
lColsTotal = UBound(arrNewHeads, 1) - LBound(arrNewHeads, 1) + 1
ReDim arrResult(1 To n * lRowsTotal, 1 To lColsTotal)
lCnt = 0
For i = 1 To lRowsTotal
For j = 1 To n
If IsNumeric(arrData(i, j)) Then
lCnt = lCnt + 1
arrResult(lCnt, 1) = arrDebitor(i, 1)
arrResult(lCnt, 2) = arrHeads(1, j)
arrResult(lCnt, 3) = arrData(i, j)
End If 'IsNumeric(arrData(i, j))
Next j
Next i
If lCnt > 0 Then
With Workbooks.Add.Sheets(1)
.Cells(1, 1).Resize(, lColsTotal).Value = arrNewHeads
.Cells(2, 1).Resize(lCnt, lColsTotal).Value = arrResult
End With 'Workbooks.Add.Sheets(1)
End If 'lCnt > 0
End Sub
Формула массива (ФМ) вводится Ctrl+Shift+Enter Memento mori
Два момента: подскажите, пожалуйста, где в коде поправить, чтобы вся эта красота появлялась не в новой книге, а в этой же на соседнем листе? И второй... я понимаю, что виноват, и сразу не указал это в первом сообщении, за что дико извиняюсь, но если Вы проявите благодушие, и поможете еще раз, я буду очень Вам благодарен ... кол-во строк и столбцов может меняться.
Макрос предполагает, что таблица начинается со строки 1 (а не 4, как в Вашем файле).
Макрос
Код
Sub Транспонировать()
Dim arrSrc(), arrRes()
Dim r As Long, i As Long, j As Long
arrSrc() = Range("A1").CurrentRegion.Value
ReDim arrRes(1 To UBound(arrSrc, 1) * UBound(arrSrc, 2), 1 To 3)
For i = 2 To UBound(arrSrc, 1)
For j = 2 To UBound(arrSrc, 2)
If arrSrc(i, j) <> "" Then
r = r + 1
arrRes(r, 1) = arrSrc(i, 1)
arrRes(r, 2) = arrSrc(1, j)
arrRes(r, 3) = arrSrc(i, j)
End If
Next j
Next i
Worksheets.Add After:=ActiveSheet
Range("A1:C1").Value = Array("Дебитор", "Attribute", "Value")
Range("A2").Resize(UBound(arrRes, 1), UBound(arrRes, 2)).Value = arrRes()
End Sub