Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Sub fSh_Tbl_ChooseVDC()
Dim rngIns As Range
Dim tbl As ListObject
Dim dic As New Dictionary
Dim aReg, aVDC, aWorks(), aOut(), aVal(), aInd() As Long
Dim x, CCDS$, hier$, r&, rr&, c&, i&, f As Boolean
f_Parameters True
r = f_File_OpenBase(): If r = 0 Then GoTo fin
If f_File_Table_GetByShCodeName(ActiveWorkbook, "shReg", tbl, True, True) = 2 Then aReg = tbl.DataBodyRange.Value Else GoTo fin
If f_File_Table_GetByShCodeName(ActiveWorkbook, "shVDC", tbl, True, True) = 2 Then aVDC = tbl.DataBodyRange.Value Else GoTo fin
If r = 2 Then ActiveWorkbook.Close False Else ThisWorkbook.Activate
' Get CCDS ======================================
For r = 1 To UBound(aVDC, 1)
If aVDC(r, 1) <> vpWCheck Then MsgBox "В столбце проверки ВДЦ найдены ошибки!", vbCritical, "ОШИБКА ВДЦ": GoTo fin
dic(aVDC(r, 26)) = dic(aVDC(r, 26)) + 1 ' CCDS-Count
Next r
x = dic.Keys: If Not f_FrmCh_FormStart(x, True, "Список Контрактов и ДС к ним") Then Exit Sub
CCDS = x(1) ' 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
ReDim aWorks(dic(CCDS), 20) ' Лимит, KKS, О, Р, П, Г, З, Шифр иерархии, Тип строки, Ключ ВДЦ, Наименование, Ед. изм., Кол-во, ВДЦ Цена за 1 ед., Закрыто ранее %, О_имя, Р_имя, П_имя, Г_имя, З_имя
ReDim aVal(UBound(aWorks, 1)): ReDim aInd(UBound(aVal)): dic.RemoveAll
' GetTable ======================================
For r = 1 To UBound(aVDC, 1)
If aVDC(r, 26) = CCDS Then
rr = rr + 1 ' Новая строка
aInd(rr) = rr ' Массив индексов для сортировки
aVal(rr) = aVDC(r, 3) ' Массив значений для сортировки
x = Split(aVDC(r, 14), ".") ' Разделение иерархии
aWorks(rr, 1) = aVDC(r, 5) ' Номер Лимита
aWorks(rr, 2) = aVDC(r, 8) ' KKS
hier = x(0): i = 0
aWorks(rr, 3) = hier ' Объект
For c = 4 To 7 ' Раздел, ПодРаздел, Группа, Заголовок
Select Case aVDC(r, c + 6)
Case vpWDash: aWorks(rr, c) = vpWDash
Case Else: i = i + 1: aWorks(rr, c) = hier & "." & x(i): hier = aWorks(rr, c)
End Select
Next c
aWorks(rr, 8) = aVDC(r, 14) ' Шифр иерархии
' aWorks(rr, 9) ' Тип строки
aWorks(rr, 10) = aVDC(r, 4) ' Ключ строки ВДЦ
dic.Add aVDC(r, 4), 0 ' KeyVDC-Balance
aWorks(rr, 11) = aVDC(r, 15) ' Наименование
aWorks(rr, 12) = aVDC(r, 16) ' Ед.Изм.
aWorks(rr, 13) = aVDC(r, 17) ' Кол-во
aWorks(rr, 14) = aVDC(r, 18) ' Цена
' aWorks(rr, 15) ' Закрыто Ранее
For c = 16 To 20
aWorks(rr, c) = aVDC(r, c - 7) ' ОРПГЗ имена
Next c
End If
Next r
f_Sort1dRecur_WithInd aVal, aInd, 1, UBound(aInd): Erase aVal
f_Sort2d_ByIndexes aWorks, aInd: Erase aInd
' Fill Balance ==================================
For r = 1 To UBound(aVDC, 1)
If aVDC(r, 26) = CCDS Then
If Not dic.Exists(aVDC(r, 4)) Then Stop: End
dic(aVDC(r, 4)) = aVDC(r, 24)
End If
Next r
' Add Headers ===================================
ReDim aOut(5 * UBound(aWorks, 1), 15): r = 1: rr = 0
x = Array("о", "р", "п", "г", "з")
For c = 3 To 7
If aWorks(r, c) <> vpWDash Then rr = rr + 1: FillHeader aOut, aWorks, rr, r, x(c - 2)
Next c
rr = rr + 1: FillHeader aOut, aWorks, rr, r
For r = 2 To UBound(aWorks, 1)
f = False
For c = 3 To 7
If aWorks(r, c) <> vpWDash Then
If Not f Then f = (aWorks(r, c) <> aWorks(r - 1, c))
If f Then rr = rr + 1: FillHeader aOut, aWorks, rr, r, x(c - 2)
End If
Next c
rr = rr + 1: FillHeader aOut, aWorks, rr, r
Next r
' Out ===========================================
On Error Resume Next: shTbl.ShowAllData: On Error GoTo 0
If Not shTbl.ListObjects(1).DataBodyRange Is Nothing Then shTbl.ListObjects(1).DataBodyRange.Rows.Delete
[_tbl_VDC].Resize(rr, UBound(aOut, 2)).Value2 = aOut
Application.Goto shTbl.Cells(1, 1)
fin: On Error GoTo 0: f_Parameters
End Sub
'--------------------------------------------------------------------------------------------------
Private Function FillHeader(aOut(), aWorks(), rO&, rW&, Optional ByVal txType$) As Boolean
Dim c&
aOut(rO, 1) = aWorks(rW, 1) ' Лимит
aOut(rO, 2) = aWorks(rW, 2) ' KKS
aOut(rO, 3) = aWorks(rW, 3) ' О
Select Case txType
Case "": For c = 4 To UBound(aOut, 2)
aOut(rO, c) = aWorks(rW, c)
Next c
Case "з": aOut(rO, 4) = aWorks(rW, 4) ' Р
aOut(rO, 5) = aWorks(rW, 5) ' П
aOut(rO, 6) = aWorks(rW, 6) ' Г
aOut(rO, 7) = aWorks(rW, 7) ' З
aOut(rO, 8) = aWorks(rW, 7) ' Иерархия полная
aOut(rO, 9) = "з" ' Тип строки
aOut(rO, 11) = aWorks(rW, 20) ' З_имя
Case "г": aOut(rO, 4) = aWorks(rW, 4) ' Р
aOut(rO, 5) = aWorks(rW, 5) ' П
aOut(rO, 6) = aWorks(rW, 6) ' Г
aOut(rO, 7) = vpWDash ' З
aOut(rO, 8) = aWorks(rW, 6) ' Иерархия полная
aOut(rO, 9) = "г" ' Тип строки
aOut(rO, 11) = aWorks(rW, 19) ' Г_имя
Case "п": aOut(rO, 4) = aWorks(rW, 4) ' Р
aOut(rO, 5) = aWorks(rW, 5) ' П
aOut(rO, 6) = vpWDash ' Г
aOut(rO, 7) = vpWDash ' З
aOut(rO, 8) = aWorks(rW, 5) ' Иерархия полная
aOut(rO, 9) = "п" ' Тип строки
aOut(rO, 11) = aWorks(rW, 18) ' П_имя
Case "р": aOut(rO, 4) = aWorks(rW, 4) ' Р
aOut(rO, 5) = vpWDash ' П
aOut(rO, 6) = vpWDash ' Г
aOut(rO, 7) = vpWDash ' З
aOut(rO, 8) = aWorks(rW, 4) ' Иерархия полная
aOut(rO, 9) = "р" ' Тип строки
aOut(rO, 11) = aWorks(rW, 17) ' Р_имя
Case "о": aOut(rO, 4) = vpWDash ' Р
aOut(rO, 5) = vpWDash ' П
aOut(rO, 6) = vpWDash ' Г
aOut(rO, 7) = vpWDash ' З
aOut(rO, 8) = aWorks(rW, 3) ' Иерархия полная
aOut(rO, 9) = "о" ' Тип строки
aOut(rO, 11) = aWorks(rW, 16) ' О_имя
Case Else: Stop: End
End Select
FillHeader = True
End Function
'==================================================================================================
'==================================================================================================
|
