Option Explicit
Sub Сумм_диапазон()
Dim rSource As Range
On Error Resume Next
Set rSource = Application.InputBox("Выберите диапазон-источник", "Суммирование", Default:="1:9", Type:=8)
Set rSource = Intersect(rSource, rSource.Parent.UsedRange)
On Error GoTo 0
If rSource Is Nothing Then Exit Sub
Dim aSor As Variant
aSor = rSource.Value
ClearArray aSor
Dim aTar As Variant, dic As Object
aTar = GetTargetArray(aSor, dic)
If IsEmpty(aTar) Then Exit Sub
FillTargetArray aTar, aSor, dic, rSource
Dim rTarget As Range
On Error Resume Next
Set rTarget = Application.InputBox("Выберите диапазон-приёмник", "Суммирование", Default:="O17", Type:=8)
Set rTarget = Intersect(rTarget, rSource.Parent.UsedRange)
On Error GoTo 0
If rTarget Is Nothing Then Exit Sub
PrintArray rTarget, aTar
End Sub
Private Sub PrintArray(rTarget As Range, aTar As Variant)
Set rTarget = rTarget.Resize(UBound(aTar, 1), UBound(aTar, 2))
rTarget.Formula = aTar
End Sub
Private Sub FillTargetArray(aTar As Variant, aSor As Variant, dic As Object, rSor As Range)
Dim ys As Long, xs As Long, xt As Long, yt As Long
For xs = 1 To UBound(aSor, 2)
If IsDate(aSor(1, xs)) Then
If aSor(1, xs) > 0 Then
For xt = 2 To UBound(aTar, 2) - 1
If aSor(1, xs) >= aTar(1, xt) Then Exit For
Next
For ys = 2 To UBound(aSor, 1)
If aSor(ys, xs) <> 0 Then
yt = dic(aSor(ys, 1)) + 2
aTar(yt, xt) = aTar(yt, xt) & rSor.Cells(ys, xs).Address(0, 0) & " "
End If
Next
End If
End If
Next
Dim ss As String
For yt = 2 To UBound(aTar, 1)
For xt = 2 To UBound(aTar, 2)
If Not IsEmpty(aTar(yt, xt)) Then
ss = aTar(yt, xt)
ss = Trim(ss)
ss = Replace(ss, " ", "+")
ss = "=" & ss
aTar(yt, xt) = ss
End If
Next
Next
End Sub
Private Function GetTargetArray(aSor As Variant, dic As Object) As Variant
Dim xs As Long, dtMin As Date, dtMax As Date
For xs = 1 To UBound(aSor, 2)
If IsDate(aSor(1, xs)) Then
If aSor(1, xs) > 0 Then
If dtMax < aSor(1, xs) Then
dtMax = aSor(1, xs)
End If
If dtMin = 0 Then
dtMin = aSor(1, xs)
ElseIf dtMin > aSor(1, xs) Then
dtMin = aSor(1, xs)
End If
End If
End If
Next
If dtMax = 0 Then Exit Function
If dtMin = 0 Then Exit Function
dtMin = DateSerial(Year(dtMin), Month(dtMin), 1)
dtMax = DateSerial(Year(dtMax), Month(dtMax), 1)
Dim dtCur As Long
xs = 0
dtCur = dtMin
Do
xs = xs + 1
If dtCur = dtMax Then Exit Do
dtCur = DateSerial(Year(dtCur), Month(dtMin) + 1, 1)
DoEvents
Loop
Dim aTarg As Variant
ReDim aTarg(1 To 1 + xs)
Set dic = CreateObject("Scripting.Dictionary")
Dim ys As Long
For xs = 1 To UBound(aSor, 2)
If IsDate(aSor(1, xs)) Then
If aSor(1, xs) > 0 Then
For ys = 2 To UBound(aSor, 1)
If aSor(ys, xs) <> 0 Then
If Not dic.Exists(aSor(ys, 1)) Then
dic(aSor(ys, 1)) = dic.Count
End If
End If
Next
End If
End If
Next
If dic.Count = 0 Then Exit Function
ReDim aTarg(1 To 1 + dic.Count, 1 To UBound(aTarg))
For ys = 0 To dic.Count - 1
aTarg(ys + 2, 1) = dic.Keys()(ys)
Next
dtCur = dtMin
For xs = 2 To UBound(aTarg, 2)
aTarg(1, xs) = dtCur
dtCur = DateSerial(Year(dtCur), Month(dtMin) + 1, 1)
Next
GetTargetArray = aTarg
End Function
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
|
