Option Explicit
Private Const TARGET_RANGE_FIRST_ROW = "G5:H5"
Private Const TARGET_LINE_COLUMN = "A"
Private Const TARGET_REF_COLUMN = "B"
Private Const TARGET_YEAR_ROW = 2
Private Const TARGET_MONTH_CELL = "C3"
Private Const SOURCE_REF_COLUMN = "C"
Private Const SOURCE_RANGE_FIRST_CELL = "E7"
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0, xlA1) = TARGET_MONTH_CELL Then Заполнить_формулы
End Sub
Sub Заполнить_формулы()
Dim shTarget As Worksheet, rTarget As Range, aTarget As Variant, aLine As Variant, aRef As Variant, aYear As Variant, monthCount As Long
Set shTarget = Sheets(1)
With shTarget
Set rTarget = .Rows(1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row)
Set rTarget = Intersect(rTarget, .Range(TARGET_RANGE_FIRST_ROW).Resize(.UsedRange.Row + .UsedRange.Rows.Count))
aLine = GetArrayFromRange(Intersect(rTarget.EntireRow, .Columns(TARGET_LINE_COLUMN)))
aRef = GetArrayFromRange(Intersect(rTarget.EntireRow, .Columns(TARGET_REF_COLUMN)))
aYear = GetArrayFromRange(Intersect(rTarget.EntireColumn, .Rows(TARGET_YEAR_ROW)))
monthCount = .Range(TARGET_MONTH_CELL).Value
End With
ReDim aTarget(1 To rTarget.Rows.Count, 1 To rTarget.Columns.Count)
FillFormulasArray aTarget, aYear, aRef, monthCount, rTarget
rTarget.Formula = aTarget
End Sub
Private Sub FillFormulasArray(aTarget As Variant, aYear As Variant, aRef As Variant, monthCount As Long, rTarget As Range)
Dim xt As Long, shSource As Worksheet
For xt = 1 To UBound(aYear, 2)
On Error Resume Next
Set shSource = Sheets(CStr(aYear(1, xt)))
On Error GoTo 0
If Not shSource Is Nothing Then
JobSourceSheet shSource, aRef, monthCount, aTarget, xt, rTarget
Set shSource = Nothing
End If
Next
End Sub
Private Sub JobSourceSheet(shSource As Worksheet, aRef As Variant, monthCount As Long, aTarget As Variant, xt As Long, rTarget As Range)
Dim dicY As Object
Set dicY = GetDicY(shSource)
Dim ss As String, st As String
ss = GetSumColumnFormula(shSource.Name, monthCount)
Dim sTotal As String, su As String
sTotal = rTarget.Cells(1, xt).EntireColumn.Cells(1, 1).Address(0, 0, xlA1)
sTotal = Replace(sTotal, 1, "")
sTotal = "=SUM(" & sTotal & "beg:" & sTotal & "fin)"
Dim yt As Long, ys As Long, yBeg As Long, yFin As Long, dy As Long
dy = rTarget.Row - 1
For yt = 1 To UBound(aRef, 1)
If Not IsEmpty(aRef(yt, 1)) Then
If dicY.Exists(CStr(aRef(yt, 1))) Then
ys = dicY(CStr(aRef(yt, 1)))
st = Replace(ss, "#", ys)
aTarget(yt, xt) = st
yFin = yt
If yBeg > 0 Then
su = Replace(sTotal, "beg", yBeg + 1 + dy)
aTarget(yBeg, xt) = Replace(su, "fin", yFin + dy)
End If
End If
Else
yBeg = yt
End If
Next
End Sub
Private Function GetSumColumnFormula(shSource_Name As String, monthCount As Long) As String
Dim xx As Long, arr As Variant
ReDim arr(1 To monthCount)
For xx = 1 To monthCount
arr(xx) = Range(SOURCE_RANGE_FIRST_CELL).EntireColumn.Cells(1, xx).Address(0, 0, xlA1)
arr(xx) = Replace(arr(xx), 1, "#")
arr(xx) = "'" & shSource_Name & "'!" & arr(xx)
Next
GetSumColumnFormula = "=" & Join(arr, "+")
End Function
Private Function GetDicY(shSource As Worksheet) As Object
Dim aRef As Variant
With shSource
aRef = .Columns(SOURCE_REF_COLUMN).Cells(Range(SOURCE_RANGE_FIRST_CELL).Row).Resize(.UsedRange.Rows.Count)
Dim dicY As Object
Set dicY = CreateObject("Scripting.Dictionary")
Dim ys As Long, dy As Long
dy = Range(SOURCE_RANGE_FIRST_CELL).Row - 1
For ys = 1 To UBound(aRef, 1)
If Not IsEmpty(aRef(ys, 1)) Then
dicY(CStr(aRef(ys, 1))) = ys + dy
End If
Next
End With
Set GetDicY = dicY
End Function
Private Function GetArrayFromRange(rr As Range) As Variant
Dim arr As Variant
If rr.Cells.CountLarge = 1 Then
ReDim arr(1 To 1, 1 To 1)
arr(1, 1) = rr.Value
Else
arr = rr.Value
End If
GetArrayFromRange = arr
End Function
|
