Option Explicit
Sub Transform1C()
CloseEmptyWb
Dim arr As Variant
arr = Intersect(Selection, ActiveSheet.UsedRange).Areas(1).Columns(1).Resize(, 2).Value
Dim brr As Variant
brr = GetFlatArray(arr)
If IsEmpty(brr) Then Exit Sub
PrintArray brr
End Sub
Private Sub PrintArray(arr As Variant)
With Workbooks.Add(1)
With .Sheets(1)
With .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
.Value = arr
.Rows(1).Font.Bold = True
End With
End With
.Saved = True
End With
End Sub
Private Function GetFlatArray(arr As Variant) As Variant
Dim dicX As Object
Set dicX = CreateObject("Scripting.Dictionary")
Dim dicY As Object
Set dicY = CreateObject("Scripting.Dictionary")
Dim ya As Long
For ya = 1 To UBound(arr, 1)
If IsSklad(arr(ya, 2)) Then
If Not dicX.Exists(arr(ya, 1)) Then dicX.Item(arr(ya, 1)) = dicX.Count + 2
Else
If Not dicY.Exists(arr(ya, 1)) Then dicY.Item(arr(ya, 1)) = dicY.Count + 2
End If
Next
If dicX.Count = 0 Then Exit Function
If dicY.Count = 0 Then Exit Function
Dim xb As Long
Dim yb As Long
Dim brr As Variant
ReDim brr(1 To dicY.Items()(dicY.Count - 1), 1 To dicX.Items()(dicX.Count - 1))
brr(1, 1) = "Продукция"
For yb = 0 To dicY.Count - 1
brr(dicY.Items()(yb), 1) = dicY.Keys()(yb)
Next
For yb = 0 To dicX.Count - 1
brr(1, dicX.Items()(yb)) = dicX.Keys()(yb)
Next
For ya = 1 To UBound(arr, 1)
yb = 0
If IsSklad(arr(ya, 2)) Then
xb = dicX.Item(arr(ya, 1))
Else
yb = dicY.Item(arr(ya, 1))
End If
If yb > 0 Then
If xb > 0 Then
If IsNumeric(arr(ya, 2)) Then
brr(yb, xb) = brr(yb, xb) + arr(ya, 2)
End If
End If
End If
Next
GetFlatArray = brr
End Function
Private Function IsSklad(ByVal ss As String) As Boolean
Select Case ss
Case "", "Кол-во"
IsSklad = True
End Select
End Function
Private Sub CloseEmptyWb()
Dim wb As Workbook
For Each wb In Application.Workbooks
If wb.Path = "" Then wb.Close False
Next
End Sub
|