Option Explicit
Sub Заполнить_таблицу()
Dim sh As Worksheet
Set sh = ActiveSheet
Dim tbSource As ListObject
Set tbSource = GetListObject(sh, "", Array("Менеджер", "Начало", "Конец"))
If tbSource Is Nothing Then Exit Sub
Dim tbTarget As ListObject
Set tbTarget = GetListObject(sh, tbSource.Name, Array("Дата", "Менеджер"))
If tbTarget Is Nothing Then Exit Sub
Dim dicY As Object
Set dicY = GetDicY(tbSource)
Dim aBegSource As Variant, aEndSource As Variant
aBegSource = GetArray(tbSource.ListColumns("Начало").DataBodyRange)
aEndSource = GetArray(tbSource.ListColumns("Конец").DataBodyRange)
Dim aManagerTarget As Variant, aDateTarget As Variant, rBodyTarget As Range, aBodyTarget As Variant, aBodySource As Variant
aManagerTarget = GetArray(tbTarget.ListColumns("Менеджер").DataBodyRange)
aDateTarget = GetArray(tbTarget.ListColumns("Дата").DataBodyRange)
Set rBodyTarget = tbTarget.ListColumns("Менеджер").DataBodyRange.Columns(2).Resize(, tbTarget.Range.Columns.Count - 2)
ReDim aBodyTarget(1 To rBodyTarget.Rows.Count, 1 To rBodyTarget.Columns.Count)
aBodySource = GetArray(tbSource.ListColumns("Конец").DataBodyRange.Columns(2).Resize(, rBodyTarget.Columns.Count))
Dim goodYs As Object
Set goodYs = CreateObject("Scripting.Dictionary")
Dim yt As Long, xt As Long, ys As Variant
For yt = 1 To UBound(aManagerTarget, 1)
If dicY.Exists(aManagerTarget(yt, 1)) Then
For Each ys In Split(dicY(aManagerTarget(yt, 1)), " ")
If ys <> "" Then
If (aDateTarget(yt, 1) >= aBegSource(ys, 1)) And (aDateTarget(yt, 1) <= aEndSource(ys, 1)) Then
For xt = 1 To UBound(aBodyTarget, 2)
aBodyTarget(yt, xt) = aBodySource(ys, xt)
Next
' goodYs(ys) = Empty
Else
' For xt = 1 To UBound(aBodyTarget, 2)
' If aBodySource(ys, xt) <> 0 Then
' aBodyTarget(yt, xt) = "?Дата"
' Else
' aBodyTarget(yt, xt) = aBodySource(ys, xt)
' End If
' Next
End If
End If
Next
Else
For xt = 1 To UBound(aBodyTarget, 2)
aBodyTarget(yt, xt) = "?Менеджер"
Next
End If
Next
For yt = 1 To UBound(aManagerTarget, 1)
If dicY.Exists(aManagerTarget(yt, 1)) Then
For Each ys In Split(dicY(aManagerTarget(yt, 1)), " ")
If ys <> "" Then
If (aDateTarget(yt, 1) >= aBegSource(ys, 1)) And (aDateTarget(yt, 1) <= aEndSource(ys, 1)) Then
ElseIf Not goodYs.Exists(ys) Then
For xt = 1 To UBound(aBodyTarget, 2)
If IsEmpty(aBodyTarget(yt, xt)) Then
If aBodySource(ys, xt) <> 0 Then
aBodyTarget(yt, xt) = "?Дата"
Else
aBodyTarget(yt, xt) = aBodySource(ys, xt)
End If
End If
Next
End If
End If
Next
End If
Next
rBodyTarget.Value = aBodyTarget
End Sub
Private Function GetDicY(tb As ListObject) As Object
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim arr As Variant, ya As Long
arr = GetArray(tb.ListColumns("Менеджер").DataBodyRange)
For ya = 1 To UBound(arr, 1)
If arr(ya, 1) <> "" Then
dic(arr(ya, 1)) = dic(arr(ya, 1)) & " " & CStr(ya)
End If
Next
Set GetDicY = dic
End Function
Private Function GetListObject(sh As Worksheet, exceptName As String, aHeader As Variant) As ListObject
Dim tb As ListObject, vHeader As Variant
For Each tb In sh.ListObjects
If tb.Name = exceptName Then GoTo next_table
For Each vHeader In aHeader
If WorksheetFunction.CountIfs(tb.HeaderRowRange, vHeader) = 0 Then
GoTo next_table
End If
Next
Set GetListObject = tb
Exit Function
next_table:
Next
End Function
Private Function GetArray(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
ClearArray arr
GetArray = arr
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
|
