Option Explicit
Sub Poroda()
Dim shTarg As Worksheet
Set shTarg = Sheets("итоговая таблица")
Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
Dim dicP As Object
FillTargetSheetPorodaCell shTarg, Sheets("исходные данные"), shTarg.Range("Z7").Value, shTarg.Range("AA7").Value, dicP
Dim dicR As Object
Set dicR = GetPorodaCells(shTarg, dicP)
FillTargetSheet shTarg, Sheets("исходные данные"), shTarg.Range("Z7").Value, shTarg.Range("AA7").Value, dicR
Application.Calculation = Application_Calculation
End Sub
Private Sub FillTargetSheetPorodaCell(shTarg As Worksheet, shSource As Worksheet, leshoz As String, uchastok As String, dicP As Object)
Dim rs As Range, ars As Variant, ys As Long
Set rs = shSource.UsedRange
ars = rs.Value
Set dicP = CreateObject("Scripting.Dictionary")
Dim prefix As String
prefix = "='" & shSource.Name & "'!E"
For ys = 1 To UBound(ars, 1)
If ars(ys, 1) = uchastok Then
If ars(ys, 2) = leshoz Then
If ars(ys, 5) <> "" Then
If Not dicP.Exists(ars(ys, 5)) Then dicP(ars(ys, 5)) = prefix & ys
End If
End If
End If
Next
End Sub
Private Sub FillTargetSheet(shTarg As Worksheet, shSource As Worksheet, leshoz As String, uchastok As String, dicR As Object)
' ClearTables shTarg, dicR
Dim dic As Object
Set dic = GetDic(dicR)
Dim rs As Range, ars As Variant, ys As Long
Set rs = shSource.UsedRange
ars = rs.Value
Dim dy As Long, ct As Range
For ys = 1 To UBound(ars, 1)
If ars(ys, 1) = uchastok Then
If ars(ys, 2) = leshoz Then
If dicR.Exists(ars(ys, 5)) Then
dy = dic(ars(ys, 5))
If dy < 25 Then
Set ct = shTarg.Range(dicR(ars(ys, 5))).Cells(dy, 0)
ct.Formula = "='" & shSource.Name & "'!F" & ys
ct.Resize(1, 10).FormulaR1C1 = ct.FormulaR1C1
shTarg.Range("H1") = "='" & shSource.Name & "'!C" & ys
shTarg.Range("H2") = "='" & shSource.Name & "'!D" & ys
dic(ars(ys, 5)) = dic(ars(ys, 5)) + 1
End If
End If
End If
End If
Next
shTarg.UsedRange.Calculate
End Sub
'Private Sub ClearTables(shTarg As Worksheet, dicR As Object)
' Dim vv As Variant, rr As Range
' For Each vv In dicR.Items
' Set rr = shTarg.Range(vv)
' Set rr = rr.Cells(5, 0)
' Set rr = rr.Resize(20, 10)
' rr.ClearContents
' Next
'End Sub
Private Function GetDic(dicR As Object) As Object
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim vv As Variant
For Each vv In dicR.Keys
dic(vv) = 5
Next
Set GetDic = dic
End Function
Private Function GetPorodaCells(sh As Worksheet, dicP As Object) As Object
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim rr As Range, rp As Range
Set rr = sh.UsedRange
Dim aur As Variant
aur = rr.Value
Dim ya As Long, xa As Long
For ya = 1 To UBound(aur, 1)
For xa = 1 To UBound(aur, 2)
If Not IsError(aur(ya, xa)) Then
If aur(ya, xa) = "Порода" Then
If rr.Cells(ya, xa).MergeArea.Columns.Count = 2 Then
If dicP.Count > 0 Then
rr.Cells(ya, xa + 2).Value = dicP.Items()(0)
dic(dicP.Keys()(0)) = rr.Cells(ya, xa).Address(0, 0, xlA1)
dicP.Remove dicP.Keys()(0)
Else
rr.Cells(ya, xa + 2).ClearContents
End If
Set rp = rr.Cells(ya, xa)
Set rp = rp.Cells(5, 0)
Set rp = rp.Resize(20, 10)
rp.ClearContents
End If
End If
End If
Next
Next
Set GetPorodaCells = dic
End Function
|
