Option Explicit
Sub myPrint()
CloseEmptyWb
Dim rr As Range
On Error Resume Next
Set rr = Intersect(Selection, ActiveSheet.UsedRange)
On Error GoTo 0
Dim arr As Variant
arr = rr.Columns(1).Resize(, 6).Value
ClearArray arr
Dim yb As Long
Dim brr As Variant
ReDim brr(1 To UBound(arr, 1) + 1, 1 To UBound(arr, 1) + 1)
Dim dicX As Object: Set dicX = CreateObject("Scripting.Dictionary")
Dim dicY As Object: Set dicY = CreateObject("Scripting.Dictionary")
Dim crr As Variant
ReDim crr(0 To 1)
Dim yc As Long
For yc = LBound(crr) To UBound(crr)
crr(yc) = brr
Set dicY.Item(yc) = CreateObject("Scripting.Dictionary")
Next
Dim sd As String
Dim dt As Date
Dim xa As Long
Dim ya As Long
Dim yi As Long
For ya = 1 To UBound(arr, 1)
If IsNumeric(arr(ya, 5)) Then
If IsNumeric(arr(ya, 6)) Then
If arr(ya, 5) < 60 Then
yc = 0
Else
yc = 1
End If
sd = Left(arr(ya, 1), Len("01.10.2021"))
If IsDate(sd) Then
dt = DateSerial(Year(CDate(sd)), Month(CDate(sd)), 1)
If Not dicX.Exists(dt) Then
xa = dicX.Count + 1
dicX.Item(dt) = xa
For yi = LBound(crr) To UBound(crr)
crr(yi)(1, xa + 1) = dt
Next
Else
xa = dicX.Item(dt)
End If
If Not dicY.Item(yc).Exists(arr(ya, 4)) Then
yb = dicY.Item(yc).Count + 1
dicY.Item(yc).Item(arr(ya, 4)) = yb
crr(yc)(yb + 1, 1) = arr(ya, 4)
Else
yb = dicY.Item(yc).Item(arr(ya, 4))
End If
crr(yc)(yb + 1, xa + 1) = crr(yc)(yb + 1, xa + 1) + arr(ya, 5) * arr(ya, 6)
End If
End If
End If
Next
For yi = LBound(crr) To UBound(crr)
crr(yi) = ResizeArray(crr(yi))
Next
PrintArray crr
End Sub
Private Function ResizeArray(arr As Variant) As Variant
Dim ya As Long
Dim xa As Long
For ya = UBound(arr, 1) To 1 Step -1
If Not IsEmpty(arr(ya, 1)) Then Exit For
Next
For xa = UBound(arr, 2) To 1 Step -1
If Not IsEmpty(arr(1, xa)) Then Exit For
Next
Dim brr As Variant
ReDim brr(1 To ya, 1 To xa)
For ya = 1 To UBound(brr, 1)
For xa = 1 To UBound(brr, 2)
brr(ya, xa) = arr(ya, xa)
Next
Next
ResizeArray = brr
End Function
Private Sub PrintArray(crr As Variant)
Workbooks.Add (1)
Dim rOut As Range
Set rOut = Cells(1, 1)
Dim yc As Long
For yc = LBound(crr) To UBound(crr)
With rOut.Resize(UBound(crr(yc), 1), UBound(crr(yc), 2))
.Value = crr(yc)
.Rows(1).NumberFormat = "mmmm yy"
.EntireColumn.AutoFit
Set rOut = .Cells(1 + .Rows.Count + 1, 1)
End With
Next
End Sub
Private Sub ClearArray(arr As Variant)
Dim ya As Long
Dim xa As Long
For ya = LBound(arr, 1) To UBound(arr, 1)
For xa = LBound(arr, 2) To UBound(arr, 2)
If IsError(arr(ya, xa)) Then
arr(ya, xa) = Empty
End If
Next
Next
End Sub
Private Sub CloseEmptyWb()
Dim wb As Workbook
For Each wb In Application.Workbooks
If wb.Path = "" Then wb.Close False
Next
End Sub
|