https://pastein.ru/t/xWy
Загрузка данных
Option Explicit
' =========================
' НАСТРОЙКИ
' =========================
Private Const REPORT_SHEET_DASH As String = "Дашборд"
Private Const REPORT_SHEET_SUMMARY As String = "Сводка"
Private Const REPORT_SHEET_REPAIRS As String = "Ремонты"
Private Const REPORT_SHEET_REASONS As String = "Причины"
Private Const REPORT_SHEET_FILES As String = "Файлы"
Private Const REPORT_SHEET_DES As String = "ДЭС_НП"
Private Const REPORT_SHEET_BOIL As String = "Котельные_НП"
Private Const SRC_SHEET_DES As String = "ДЭС"
Private Const SRC_SHEET_BOILERS As String = "Котельные"
Private Const SRC_SHEET_REPAIRS As String = "Ремонт оборудования"
' Лист ДЭС
Private Const DES_COL_STATE_WORK As Long = 8 ' H
Private Const DES_COL_STATE_RESERVE As Long = 9 ' I
Private Const DES_COL_STATE_REPAIR As Long = 10 ' J
Private Const DES_COL_NAME As Long = 11 ' K
Private Const DES_COL_LOAD_MAXDAY As Long = 20 ' T
Private Const DES_COL_OIL As Long = 23 ' W
Private Const DES_COL_FUEL As Long = 25 ' Y
Private Const DES_COL_OUTPUT As Long = 42 ' AP
Private gDES As Object
Private gBoilers As Object
' =========================
' ГЛАВНЫЙ ЗАПУСК
' =========================
Public Sub ОбновитьДанные()
Dim folderPath As String
Dim fileName As String
Dim fullPath As String
Dim wb As Workbook
Dim reportName As String
Dim dt As Variant
Dim wsDash As Worksheet, wsSummary As Worksheet, wsRepairs As Worksheet
Dim wsReasons As Worksheet, wsFiles As Worksheet, wsDES As Worksheet, wsBoil As Worksheet
Dim dictSummary As Object
Dim dictReasons As Object
Dim repairsRow As Long
Dim filesRow As Long
On Error GoTo EH
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False
Application.Calculation = xlCalculationManual
Application.StatusBar = "Обновление отчета..."
folderPath = ThisWorkbook.Path
If Len(folderPath) = 0 Then
MsgBox "Сначала сохраните файл отчета в папку с исходными файлами.", vbExclamation
GoTo SafeExit
End If
reportName = ThisWorkbook.Name
Set dictSummary = CreateObject("Scripting.Dictionary")
Set dictReasons = CreateObject("Scripting.Dictionary")
Set gDES = CreateObject("Scripting.Dictionary")
Set gBoilers = CreateObject("Scripting.Dictionary")
PrepareSheets wsDash, wsSummary, wsRepairs, wsReasons, wsFiles, wsDES, wsBoil
repairsRow = 2
filesRow = 2
fileName = Dir(folderPath & "\*.xls*")
Do While fileName <> ""
If LCase$(fileName) <> LCase$(reportName) And Left$(fileName, 2) <> "~$" Then
fullPath = folderPath & "\" & fileName
dt = ExtractDateFromFileName(fileName)
If IsDate(dt) Then
Set wb = Nothing
On Error Resume Next
Set wb = Workbooks.Open(Filename:=fullPath, ReadOnly:=True, UpdateLinks:=False, IgnoreReadOnlyRecommended:=True)
On Error GoTo EH
If Not wb Is Nothing Then
ProcessWorkbook wb, CDate(dt), fileName, dictSummary, dictReasons, wsRepairs, repairsRow, wsFiles, filesRow
wb.Close SaveChanges:=False
Set wb = Nothing
Else
LogFile wsFiles, filesRow, fileName, CDate(dt), "Ошибка", "Не удалось открыть файл"
filesRow = filesRow + 1
End If
Else
LogFile wsFiles, filesRow, fileName, Empty, "Пропущен", "Не найдена дата в имени файла"
filesRow = filesRow + 1
End If
End If
fileName = Dir
Loop
ExportSummary wsSummary, dictSummary
ExportReasons wsReasons, dictReasons
ExportDESBlocks wsDES, gDES
ExportBoilerBlocks wsBoil, gBoilers
BuildDashboard wsDash, wsSummary, wsReasons, wsDES, wsBoil
FormatSheets wsSummary, wsRepairs, wsReasons, wsFiles, wsDash, wsDES, wsBoil
MsgBox "Обновление завершено.", vbInformation
SafeExit:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.AskToUpdateLinks = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
Exit Sub
EH:
MsgBox "Ошибка при обновлении: " & Err.Description, vbCritical
Resume SafeExit
End Sub
Public Sub СоздатьКнопкуОбновления()
Dim ws As Worksheet
Dim shp As Shape
Set ws = GetOrCreateSheet(REPORT_SHEET_DASH)
On Error Resume Next
ws.Shapes("btnRefresh").Delete
On Error GoTo 0
Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, 700, 20, 180, 35)
shp.Name = "btnRefresh"
shp.TextFrame.Characters.Text = "Обновить данные"
shp.OnAction = "ОбновитьДанные"
End Sub
' =========================
' ПОДГОТОВКА ЛИСТОВ
' =========================
Private Sub PrepareSheets(ByRef wsDash As Worksheet, ByRef wsSummary As Worksheet, ByRef wsRepairs As Worksheet, ByRef wsReasons As Worksheet, ByRef wsFiles As Worksheet, ByRef wsDES As Worksheet, ByRef wsBoil As Worksheet)
Set wsDash = GetOrCreateSheet(REPORT_SHEET_DASH)
Set wsSummary = GetOrCreateSheet(REPORT_SHEET_SUMMARY)
Set wsRepairs = GetOrCreateSheet(REPORT_SHEET_REPAIRS)
Set wsReasons = GetOrCreateSheet(REPORT_SHEET_REASONS)
Set wsFiles = GetOrCreateSheet(REPORT_SHEET_FILES)
Set wsDES = GetOrCreateSheet(REPORT_SHEET_DES)
Set wsBoil = GetOrCreateSheet(REPORT_SHEET_BOIL)
wsDash.Cells.Clear
wsSummary.Cells.Clear
wsRepairs.Cells.Clear
wsReasons.Cells.Clear
wsFiles.Cells.Clear
wsDES.Cells.Clear
wsBoil.Cells.Clear
wsSummary.Range("A1:M1").Value = Array( _
"Дата", "Файлов", "Ремонтов", "Нагрузка ДЭС, кВт", "Выработка ДЭС, кВт", _
"Топливо ДЭС, л", "Топливо котельных, м3", "Общее топливо", _
"ДГУ в работе", "ДГУ в резерве", "ДГУ в ремонте", "Кол-во причин", "Расход масла ДЭС")
wsRepairs.Range("A1:F1").Value = Array("Дата", "Источник", "Объект/оборудование", "Причина", "Примечание", "Исходный файл")
wsReasons.Range("A1:B1").Value = Array("Причина", "Количество")
wsFiles.Range("A1:D1").Value = Array("Файл", "Дата", "Статус", "Комментарий")
wsDES.Range("A1:M1").Value = Array( _
"Дата", "Блок ДЭС", "Нагрузка мин", "Нагрузка макс", "Нагрузка средняя", "Нагрузка сумма", _
"Выработка", "Топливо ДЭС", "Масло ДЭС", "Кол-во установок", "В работе", "В резерве", "В ремонте")
wsBoil.Range("A1:F1").Value = Array( _
"Дата", "Блок котельной", "Топливо мин", "Топливо макс", "Топливо среднее", "Топливо сумма")
End Sub
' =========================
' ОБРАБОТКА КНИГИ
' =========================
Private Sub ProcessWorkbook(ByVal wb As Workbook, ByVal dt As Date, ByVal fileName As String, ByVal dictSummary As Object, ByVal dictReasons As Object, ByVal wsRepairs As Worksheet, ByRef repairsRow As Long, ByVal wsFiles As Worksheet, ByRef filesRow As Long)
Dim desLoad As Double
Dim desOutput As Double
Dim desFuel As Double
Dim boilersFuel As Double
Dim totalFuel As Double
Dim desOil As Double
Dim cntRepairs As Long
Dim cntWork As Long, cntReserve As Long, cntRepairState As Long
Dim okAny As Boolean
okAny = False
desLoad = ReadDESLoadStatus(wb, dt, cntWork, cntReserve, cntRepairState)
desOutput = ReadDESOutput(wb, dt)
desFuel = ReadDESFuel(wb, dt)
desOil = ReadDESOil(wb, dt)
boilersFuel = ReadBoilerFuel(wb, dt)
totalFuel = desFuel + boilersFuel
cntRepairs = ReadRepairs(wb, dt, fileName, dictReasons, wsRepairs, repairsRow)
If desLoad <> 0 Or desOutput <> 0 Or desFuel <> 0 Or boilersFuel <> 0 Or desOil <> 0 Then okAny = True
If cntWork <> 0 Or cntReserve <> 0 Or cntRepairState <> 0 Then okAny = True
If cntRepairs <> 0 Then okAny = True
AddToSummary dictSummary, dt, 1, cntRepairs, desLoad, desOutput, desFuel, boilersFuel, totalFuel, cntWork, cntReserve, cntRepairState, desOil
If okAny Then
LogFile wsFiles, filesRow, fileName, dt, "ОК", "Обработан"
Else
LogFile wsFiles, filesRow, fileName, dt, "ОК", "Файл открыт, но данные не распознаны"
End If
filesRow = filesRow + 1
End Sub
' =========================
' ДЭС
' =========================
Private Function ReadDESLoadStatus(ByVal wb As Workbook, ByVal dt As Date, ByRef cntWork As Long, ByRef cntReserve As Long, ByRef cntRepair As Long) As Double
Dim ws As Worksheet
Dim r As Long, lastRow As Long
Dim blockName As String
Dim loadVal As Double
Dim vRun As Variant, vReserve As Variant, vRepair As Variant
Dim stWork As Long, stReserve As Long, stRepair As Long
Dim totalLoad As Double
On Error Resume Next
Set ws = wb.Worksheets(SRC_SHEET_DES)
On Error GoTo 0
If ws Is Nothing Then Exit Function
lastRow = LastRow(ws)
blockName = ""
totalLoad = 0
For r = 1 To lastRow
If IsDESBlockHeader(ws, r) Then
blockName = GetDESBlockName(ws, r)
EnsureDESBlock dt, blockName
ElseIf IsDESEquipmentRow(ws, r) Then
If blockName = "" Then blockName = "Не определено"
loadVal = ToNumber(ws.Cells(r, DES_COL_LOAD_MAXDAY).Value)
vRun = ws.Cells(r, DES_COL_STATE_WORK).Value
vReserve = ws.Cells(r, DES_COL_STATE_RESERVE).Value
vRepair = ws.Cells(r, DES_COL_STATE_REPAIR).Value
stWork = 0
stReserve = 0
stRepair = 0
If Trim$(CStr(vRun)) = "+" Then
cntWork = cntWork + 1
stWork = 1
End If
If Trim$(CStr(vReserve)) = "+" Then
cntReserve = cntReserve + 1
stReserve = 1
End If
If LCase$(Trim$(CStr(vRepair))) = "ремонт" Or Trim$(CStr(vRepair)) = "+" Then
cntRepair = cntRepair + 1
stRepair = 1
End If
totalLoad = totalLoad + loadVal
UpdateDESBlock dt, blockName, loadVal, 0, 0, 0, stWork, stReserve, stRepair
End If
Next r
ReadDESLoadStatus = totalLoad
End Function
Private Function ReadDESOutput(ByVal wb As Workbook, ByVal dt As Date) As Double
Dim ws As Worksheet
Dim r As Long, lastRow As Long
Dim blockName As String
Dim v As Double, totalV As Double
On Error Resume Next
Set ws = wb.Worksheets(SRC_SHEET_DES)
On Error GoTo 0
If ws Is Nothing Then Exit Function
lastRow = LastRow(ws)
blockName = ""
For r = 1 To lastRow
If IsDESBlockHeader(ws, r) Then
blockName = GetDESBlockName(ws, r)
EnsureDESBlock dt, blockName
ElseIf IsDESEquipmentRow(ws, r) Then
If blockName = "" Then blockName = "Не определено"
v = ToNumber(ws.Cells(r, DES_COL_OUTPUT).Value)
totalV = totalV + v
UpdateDESBlock dt, blockName, 0, v, 0, 0, 0, 0, 0
End If
Next r
ReadDESOutput = totalV
End Function
Private Function ReadDESFuel(ByVal wb As Workbook, ByVal dt As Date) As Double
Dim ws As Worksheet
Dim r As Long, lastRow As Long
Dim blockName As String
Dim v As Double, totalV As Double
On Error Resume Next
Set ws = wb.Worksheets(SRC_SHEET_DES)
On Error GoTo 0
If ws Is Nothing Then Exit Function
lastRow = LastRow(ws)
blockName = ""
For r = 1 To lastRow
If IsDESBlockHeader(ws, r) Then
blockName = GetDESBlockName(ws, r)
EnsureDESBlock dt, blockName
ElseIf IsDESEquipmentRow(ws, r) Then
If blockName = "" Then blockName = "Не определено"
v = ToNumber(ws.Cells(r, DES_COL_FUEL).Value)
totalV = totalV + v
UpdateDESBlock dt, blockName, 0, 0, v, 0, 0, 0, 0
End If
Next r
ReadDESFuel = totalV
End Function
Private Function ReadDESOil(ByVal wb As Workbook, ByVal dt As Date) As Double
Dim ws As Worksheet
Dim r As Long, lastRow As Long
Dim blockName As String
Dim v As Double, totalV As Double
On Error Resume Next
Set ws = wb.Worksheets(SRC_SHEET_DES)
On Error GoTo 0
If ws Is Nothing Then Exit Function
lastRow = LastRow(ws)
blockName = ""
For r = 1 To lastRow
If IsDESBlockHeader(ws, r) Then
blockName = GetDESBlockName(ws, r)
EnsureDESBlock dt, blockName
ElseIf IsDESEquipmentRow(ws, r) Then
If blockName = "" Then blockName = "Не определено"
v = ToNumber(ws.Cells(r, DES_COL_OIL).Value)
totalV = totalV + v
UpdateDESBlock dt, blockName, 0, 0, 0, v, 0, 0, 0
End If
Next r
ReadDESOil = totalV
End Function
Private Function IsDESBlockHeader(ByVal ws As Worksheet, ByVal r As Long) As Boolean
Dim txt As String
txt = Trim$(RowText(ws, r))
If txt = "" Then Exit Function
If InStr(1, txt, "АО ", vbTextCompare) > 0 Then IsDESBlockHeader = True: Exit Function
If InStr(1, txt, "ООО ", vbTextCompare) > 0 Then IsDESBlockHeader = True: Exit Function
If InStr(1, txt, "ДЭС-", vbTextCompare) > 0 Then IsDESBlockHeader = True: Exit Function
If InStr(1, txt, "ГПТЭС", vbTextCompare) > 0 Then IsDESBlockHeader = True: Exit Function
If InStr(1, txt, "ГПЭС", vbTextCompare) > 0 Then IsDESBlockHeader = True: Exit Function
If InStr(1, txt, "Харсаим ДЭС", vbTextCompare) > 0 Then IsDESBlockHeader = True: Exit Function
End Function
Private Function GetDESBlockName(ByVal ws As Worksheet, ByVal r As Long) As String
Dim s As String
s = Trim$(RowText(ws, r))
If s = "" Then s = "Не определено"
If InStr(1, s, "АО ""Харп-Энерго Газ""", vbTextCompare) > 0 Then
GetDESBlockName = "АО ""Харп-Энерго Газ"""
Exit Function
End If
If InStr(1, s, "ООО ""ВДМ-Сервис"" ГПЭС Харсаим", vbTextCompare) > 0 Then
GetDESBlockName = "ООО ""ВДМ-Сервис"" ГПЭС Харсаим ул. Объездная"
Exit Function
End If
If InStr(1, s, "Харсаим ДЭС-34", vbTextCompare) > 0 Then
GetDESBlockName = "Харсаим ДЭС-34"
Exit Function
End If
GetDESBlockName = s
End Function
Private Function IsDESEquipmentRow(ByVal ws As Worksheet, ByVal r As Long) As Boolean
Dim nm As String
Dim cntNums As Long
nm = Trim$(CStr(ws.Cells(r, DES_COL_NAME).Value))
If LCase$(nm) Like "*итого*" Then Exit Function
If LCase$(nm) Like "*фидер*" Then Exit Function
If LCase$(nm) Like "*номер*" Then Exit Function
If LCase$(nm) Like "*собствен*" Then Exit Function
If InStr(1, nm, "Ф-", vbTextCompare) > 0 _
Or InStr(1, nm, "ДГУ-", vbTextCompare) > 0 _
Or InStr(1, nm, "ГТУ-", vbTextCompare) > 0 _
Or InStr(1, nm, "РДГУ-", vbTextCompare) > 0 _
Or InStr(1, nm, "ГПА-", vbTextCompare) > 0 _
Or InStr(1, nm, "Ввод 1", vbTextCompare) > 0 _
Or InStr(1, nm, "Ввод 2", vbTextCompare) > 0 _
Or InStr(1, nm, "Ввод 3", vbTextCompare) > 0 _
Or InStr(1, nm, "Ввод 4", vbTextCompare) > 0 Then
IsDESEquipmentRow = True
Exit Function
End If
cntNums = CountNumericInRange(ws, r, 12, 20)
If cntNums >= 3 Then
IsDESEquipmentRow = True
End If
End Function
' =========================
' КОТЕЛЬНЫЕ
' =========================
Private Function ReadBoilerFuel(ByVal wb As Workbook, ByVal dt As Date) As Double
Dim ws As Worksheet
Dim fuelCol As Long
Dim r As Long, lastRow As Long
Dim blockName As String
Dim v As Double, totalV As Double
On Error Resume Next
Set ws = wb.Worksheets(SRC_SHEET_BOILERS)
On Error GoTo 0
If ws Is Nothing Then Exit Function
fuelCol = FindBoilerFuelCol(ws)
lastRow = LastRow(ws)
blockName = ""
For r = 1 To lastRow
If IsBoilerBlockHeader(ws, r) Then
blockName = GetBoilerBlockName(ws, r)
EnsureBoilerBlock dt, blockName
ElseIf IsBoilerDataRow(ws, r) Then
If blockName = "" Then blockName = "Не определено"
v = ToNumber(ws.Cells(r, fuelCol).Value)
totalV = totalV + v
UpdateBoilerBlock dt, blockName, v
End If
Next r
ReadBoilerFuel = totalV
End Function
Private Function IsBoilerBlockHeader(ByVal ws As Worksheet, ByVal r As Long) As Boolean
Dim txt As String
Dim nonEmpty As Long
txt = Trim$(RowText(ws, r))
If txt = "" Then Exit Function
nonEmpty = Application.WorksheetFunction.CountA(ws.Rows(r))
If nonEmpty <= 3 Then
If InStr(1, txt, "№", vbTextCompare) > 0 Then
IsBoilerBlockHeader = True
Exit Function
End If
If InStr(1, txt, "АО ", vbTextCompare) > 0 Then
IsBoilerBlockHeader = True
Exit Function
End If
If InStr(1, txt, "ООО ", vbTextCompare) > 0 Then
IsBoilerBlockHeader = True
Exit Function
End If
End If
End Function
Private Function GetBoilerBlockName(ByVal ws As Worksheet, ByVal r As Long) As String
Dim s As String
s = Trim$(RowText(ws, r))
If s = "" Then s = "Не определено"
GetBoilerBlockName = s
End Function
Private Function IsBoilerDataRow(ByVal ws As Worksheet, ByVal r As Long) As Boolean
Dim txt As String
txt = Trim$(RowText(ws, r))
If txt = "" Then Exit Function
If IsBoilerBlockHeader(ws, r) Then Exit Function
If InStr(1, LCase$(txt), "итого", vbTextCompare) > 0 Then Exit Function
If Application.WorksheetFunction.CountA(ws.Rows(r)) > 3 Then IsBoilerDataRow = True
End Function
Private Function FindBoilerFuelCol(ByVal ws As Worksheet) As Long
Dim r As Long, c As Long, lastCol As Long
Dim txt As String
For r = 1 To 12
lastCol = ws.Cells(r, ws.Columns.Count).End(xlToLeft).Column
For c = 1 To lastCol
txt = LCase$(Trim$(CStr(ws.Cells(r, c).Value)))
If txt <> "" Then
If InStr(txt, "расход") > 0 And InStr(txt, "топлив") > 0 And InStr(txt, "сутк") > 0 Then
FindBoilerFuelCol = c
Exit Function
End If
End If
Next c
Next r
FindBoilerFuelCol = 20
End Function
' =========================
' РЕМОНТЫ
' =========================
Private Function ReadRepairs(ByVal wb As Workbook, ByVal dt As Date, ByVal fileName As String, ByVal dictReasons As Object, ByVal wsRepairs As Worksheet, ByRef repairsRow As Long) As Long
Dim ws As Worksheet
Dim lastRow As Long, r As Long
Dim unitNo As Variant
Dim typeVal As String, engineVal As String, reasonVal As String, noteVal As String
Dim cnt As Long
On Error Resume Next
Set ws = wb.Worksheets(SRC_SHEET_REPAIRS)
On Error GoTo 0
If ws Is Nothing Then Exit Function
lastRow = LastRow(ws)
For r = 3 To lastRow
unitNo = ws.Cells(r, 2).Value
typeVal = Trim$(CStr(ws.Cells(r, 3).Value))
engineVal = Trim$(CStr(ws.Cells(r, 4).Value))
reasonVal = Trim$(CStr(ws.Cells(r, 6).Value))
noteVal = Trim$(CStr(ws.Cells(r, 8).Value))
If reasonVal <> "" And IsNumeric(unitNo) Then
wsRepairs.Cells(repairsRow, 1).Value = dt
wsRepairs.Cells(repairsRow, 2).Value = "Ремонт оборудования"
wsRepairs.Cells(repairsRow, 3).Value = Trim$(typeVal & " " & engineVal)
wsRepairs.Cells(repairsRow, 4).Value = reasonVal
wsRepairs.Cells(repairsRow, 5).Value = noteVal
wsRepairs.Cells(repairsRow, 6).Value = fileName
If dictReasons.Exists(reasonVal) Then
dictReasons(reasonVal) = CLng(dictReasons(reasonVal)) + 1
Else
dictReasons.Add reasonVal, 1
End If
repairsRow = repairsRow + 1
cnt = cnt + 1
End If
Next r
ReadRepairs = cnt
End Function
' =========================
' СЛОВАРИ БЛОКОВ
' =========================
Private Sub EnsureDESBlock(ByVal dt As Date, ByVal blockName As String)
Dim key As String
Dim arr As Variant
If blockName = "" Then blockName = "Не определено"
key = Format$(dt, "yyyy-mm-dd") & "|" & blockName
If Not gDES.Exists(key) Then
ReDim arr(1 To 10)
arr(1) = 0
arr(2) = 0
arr(3) = 0
arr(4) = 0
arr(5) = 0
arr(6) = 0
arr(7) = 0
arr(8) = 0
arr(9) = 0
arr(10) = 0
gDES.Add key, arr
End If
End Sub
Private Sub UpdateDESBlock(ByVal dt As Date, ByVal blockName As String, ByVal loadVal As Double, ByVal outputVal As Double, ByVal fuelVal As Double, ByVal oilVal As Double, ByVal stWork As Long, ByVal stReserve As Long, ByVal stRepair As Long)
Dim key As String
Dim arr As Variant
If blockName = "" Then blockName = "Не определено"
key = Format$(dt, "yyyy-mm-dd") & "|" & blockName
If Not gDES.Exists(key) Then EnsureDESBlock dt, blockName
arr = gDES(key)
If loadVal > 0 Then
If arr(1) = 0 Or loadVal < arr(1) Then arr(1) = loadVal
If loadVal > arr(2) Then arr(2) = loadVal
arr(3) = arr(3) + loadVal
arr(7) = arr(7) + 1
End If
arr(4) = arr(4) + outputVal
arr(5) = arr(5) + fuelVal
arr(6) = arr(6) + oilVal
arr(8) = arr(8) + stWork
arr(9) = arr(9) + stReserve
arr(10) = arr(10) + stRepair
gDES(key) = arr
End Sub
Private Sub EnsureBoilerBlock(ByVal dt As Date, ByVal blockName As String)
Dim key As String
Dim arr As Variant
If blockName = "" Then blockName = "Не определено"
key = Format$(dt, "yyyy-mm-dd") & "|" & blockName
If Not gBoilers.Exists(key) Then
ReDim arr(1 To 4)
arr(1) = 0
arr(2) = 0
arr(3) = 0
arr(4) = 0
gBoilers.Add key, arr
End If
End Sub
Private Sub UpdateBoilerBlock(ByVal dt As Date, ByVal blockName As String, ByVal fuelVal As Double)
Dim key As String
Dim arr As Variant
If blockName = "" Then blockName = "Не определено"
key = Format$(dt, "yyyy-mm-dd") & "|" & blockName
If Not gBoilers.Exists(key) Then EnsureBoilerBlock dt, blockName
arr = gBoilers(key)
If fuelVal > 0 Then
If arr(1) = 0 Or fuelVal < arr(1) Then arr(1) = fuelVal
If fuelVal > arr(2) Then arr(2) = fuelVal
arr(3) = arr(3) + fuelVal
arr(4) = arr(4) + 1
End If
gBoilers(key) = arr
End Sub
' =========================
' ВЫГРУЗКА
' =========================
Private Sub ExportSummary(ByVal ws As Worksheet, ByVal dictSummary As Object)
Dim keys As Variant, i As Long, r As Long, arr As Variant
If dictSummary.Count = 0 Then Exit Sub
keys = dictSummary.Keys
SortDateKeys keys
r = 2
For i = LBound(keys) To UBound(keys)
arr = dictSummary(keys(i))
ws.Cells(r, 1).Value = CDate(keys(i))
ws.Cells(r, 2).Value = arr(1)
ws.Cells(r, 3).Value = arr(2)
ws.Cells(r, 4).Value = arr(3)
ws.Cells(r, 5).Value = arr(4)
ws.Cells(r, 6).Value = arr(5)
ws.Cells(r, 7).Value = arr(6)
ws.Cells(r, 8).Value = arr(7)
ws.Cells(r, 9).Value = arr(8)
ws.Cells(r, 10).Value = arr(9)
ws.Cells(r, 11).Value = arr(10)
ws.Cells(r, 12).Formula = "=COUNTIF(Ремонты!A:A,A" & r & ")"
ws.Cells(r, 13).Value = arr(12)
r = r + 1
Next i
End Sub
Private Sub ExportReasons(ByVal ws As Worksheet, ByVal dictReasons As Object)
Dim keys As Variant, i As Long, r As Long, lastRowVal As Long
If dictReasons.Count = 0 Then Exit Sub
keys = dictReasons.Keys
r = 2
For i = LBound(keys) To UBound(keys)
ws.Cells(r, 1).Value = keys(i)
ws.Cells(r, 2).Value = dictReasons(keys(i))
r = r + 1
Next i
lastRowVal = LastRow(ws)
If lastRowVal >= 2 Then
ws.Range("A1:B" & lastRowVal).Sort Key1:=ws.Range("B2"), Order1:=xlDescending, Header:=xlYes
End If
End Sub
Private Sub ExportDESBlocks(ByVal ws As Worksheet, ByVal dictData As Object)
Dim keys As Variant, i As Long, r As Long, arr As Variant, parts() As String
Dim avgLoad As Double
If dictData Is Nothing Or dictData.Count = 0 Then Exit Sub
keys = dictData.Keys
SortStringKeys keys
r = 2
For i = LBound(keys) To UBound(keys)
arr = dictData(keys(i))
parts = Split(CStr(keys(i)), "|")
avgLoad = 0
If arr(7) > 0 Then avgLoad = arr(3) / arr(7)
ws.Cells(r, 1).Value = CDate(parts(0))
ws.Cells(r, 2).Value = parts(1)
ws.Cells(r, 3).Value = arr(1)
ws.Cells(r, 4).Value = arr(2)
ws.Cells(r, 5).Value = avgLoad
ws.Cells(r, 6).Value = arr(3)
ws.Cells(r, 7).Value = arr(4)
ws.Cells(r, 8).Value = arr(5)
ws.Cells(r, 9).Value = arr(6)
ws.Cells(r, 10).Value = arr(7)
ws.Cells(r, 11).Value = arr(8)
ws.Cells(r, 12).Value = arr(9)
ws.Cells(r, 13).Value = arr(10)
r = r + 1
Next i
End Sub
Private Sub ExportBoilerBlocks(ByVal ws As Worksheet, ByVal dictData As Object)
Dim keys As Variant, i As Long, r As Long, arr As Variant, parts() As String
Dim avgFuel As Double
If dictData Is Nothing Or dictData.Count = 0 Then Exit Sub
keys = dictData.Keys
SortStringKeys keys
r = 2
For i = LBound(keys) To UBound(keys)
arr = dictData(keys(i))
parts = Split(CStr(keys(i)), "|")
avgFuel = 0
If arr(4) > 0 Then avgFuel = arr(3) / arr(4)
ws.Cells(r, 1).Value = CDate(parts(0))
ws.Cells(r, 2).Value = parts(1)
ws.Cells(r, 3).Value = arr(1)
ws.Cells(r, 4).Value = arr(2)
ws.Cells(r, 5).Value = avgFuel
ws.Cells(r, 6).Value = arr(3)
r = r + 1
Next i
End Sub
' =========================
' ДАШБОРД
' =========================
Private Sub BuildDashboard(ByVal wsDash As Worksheet, ByVal wsSummary As Worksheet, ByVal wsReasons As Worksheet, ByVal wsDES As Worksheet, ByVal wsBoil As Worksheet)
Dim lastSummaryRow As Long, lastReasonsRow As Long, lastDESRow As Long, lastBoilRow As Long
Dim ch As ChartObject
wsDash.Cells.Clear
wsDash.Range("A1").Value = "Месячный дашборд"
wsDash.Range("A1").Font.Size = 18
wsDash.Range("A1").Font.Bold = True
wsDash.Range("A3").Value = "Файлов обработано"
wsDash.Range("B3").Formula = "=MAX(0,COUNTA(Файлы!A:A)-1)"
wsDash.Range("D3").Value = "Дней с данными"
wsDash.Range("E3").Formula = "=MAX(0,COUNTA(Сводка!A:A)-1)"
wsDash.Range("A4").Value = "Всего ремонтов"
wsDash.Range("B4").Formula = "=SUM(Сводка!C:C)"
wsDash.Range("D4").Value = "Выработка ДЭС"
wsDash.Range("E4").Formula = "=SUM(Сводка!E:E)"
wsDash.Range("A5").Value = "Топливо ДЭС"
wsDash.Range("B5").Formula = "=SUM(Сводка!F:F)"
wsDash.Range("D5").Value = "Топливо котельных"
wsDash.Range("E5").Formula = "=SUM(Сводка!G:G)"
wsDash.Range("A6").Value = "Общее топливо"
wsDash.Range("B6").Formula = "=SUM(Сводка!H:H)"
wsDash.Range("D6").Value = "Нагрузка ДЭС"
wsDash.Range("E6").Formula = "=SUM(Сводка!D:D)"
wsDash.Range("A7").Value = "Расход масла ДЭС"
wsDash.Range("B7").Formula = "=SUM(Сводка!M:M)"
wsDash.Range("D7").Value = "Последняя дата"
wsDash.Range("E7").Formula = "=MAX(Сводка!A:A)"
wsDash.Range("E7").NumberFormat = "dd.mm.yyyy"
lastSummaryRow = LastRow(wsSummary)
lastReasonsRow = LastRow(wsReasons)
lastDESRow = LastRow(wsDES)
lastBoilRow = LastRow(wsBoil)
DeleteAllCharts wsDash
wsDash.Range("J:O").Clear
If lastSummaryRow >= 2 Then
Set ch = wsDash.ChartObjects.Add(Left:=20, Top:=130, Width:=420, Height:=220)
With ch.Chart
.ChartType = xlColumnClustered
ClearSeries ch.Chart
.SeriesCollection.NewSeries
.SeriesCollection(1).Name = "=""Ремонты"""
.SeriesCollection(1).XValues = wsSummary.Range("A2:A" & lastSummaryRow)
.SeriesCollection(1).Values = wsSummary.Range("C2:C" & lastSummaryRow)
.HasTitle = True
.ChartTitle.Text = "Ремонты по дням"
End With
Set ch = wsDash.ChartObjects.Add(Left:=460, Top:=130, Width:=420, Height:=220)
With ch.Chart
.ChartType = xlLine
ClearSeries ch.Chart
.SeriesCollection.NewSeries
.SeriesCollection(1).Name = "=""Общее топливо"""
.SeriesCollection(1).XValues = wsSummary.Range("A2:A" & lastSummaryRow)
.SeriesCollection(1).Values = wsSummary.Range("H2:H" & lastSummaryRow)
.HasTitle = True
.ChartTitle.Text = "Общее топливо по дням"
End With
End If
If lastDESRow >= 2 Then
AggregateDESForDashboard wsDES, wsDash
Set ch = wsDash.ChartObjects.Add(Left:=20, Top:=380, Width:=860, Height:=260)
With ch.Chart
.ChartType = xlColumnClustered
ClearSeries ch.Chart
.SeriesCollection.NewSeries
.SeriesCollection(1).Name = "=""Мин"""
.SeriesCollection(1).XValues = wsDash.Range("J3:J" & LastRow(wsDash))
.SeriesCollection(1).Values = wsDash.Range("K3:K" & LastRow(wsDash))
.SeriesCollection.NewSeries
.SeriesCollection(2).Name = "=""Сред"""
.SeriesCollection(2).XValues = wsDash.Range("J3:J" & LastRow(wsDash))
.SeriesCollection(2).Values = wsDash.Range("L3:L" & LastRow(wsDash))
.SeriesCollection.NewSeries
.SeriesCollection(3).Name = "=""Макс"""
.SeriesCollection(3).XValues = wsDash.Range("J3:J" & LastRow(wsDash))
.SeriesCollection(3).Values = wsDash.Range("M3:M" & LastRow(wsDash))
.HasTitle = True
.ChartTitle.Text = "Мин / сред / макс нагрузки ДЭС по блокам"
End With
End If
If lastBoilRow >= 2 Then
AggregateBoilersForDashboard wsBoil, wsDash
Set ch = wsDash.ChartObjects.Add(Left:=20, Top:=960, Width:=860, Height:=260)
With ch.Chart
.ChartType = xlColumnClustered
ClearSeries ch.Chart
.SeriesCollection.NewSeries
.SeriesCollection(1).Name = "=""Мин"""
.SeriesCollection(1).XValues = wsDash.Range("J41:J" & LastRow(wsDash))
.SeriesCollection(1).Values = wsDash.Range("K41:K" & LastRow(wsDash))
.SeriesCollection.NewSeries
.SeriesCollection(2).Name = "=""Сред"""
.SeriesCollection(2).XValues = wsDash.Range("J41:J" & LastRow(wsDash))
.SeriesCollection(2).Values = wsDash.Range("L41:L" & LastRow(wsDash))
.SeriesCollection.NewSeries
.SeriesCollection(3).Name = "=""Макс"""
.SeriesCollection(3).XValues = wsDash.Range("J41:J" & LastRow(wsDash))
.SeriesCollection(3).Values = wsDash.Range("M41:M" & LastRow(wsDash))
.HasTitle = True
.ChartTitle.Text = "Мин / сред / макс топлива котельных по блокам"
End With
End If
If lastReasonsRow >= 2 Then
Set ch = wsDash.ChartObjects.Add(Left:=20, Top:=1540, Width:=860, Height:=260)
With ch.Chart
.ChartType = xlBarClustered
ClearSeries ch.Chart
.SeriesCollection.NewSeries
.SeriesCollection(1).Name = "=""Причины"""
.SeriesCollection(1).XValues = wsReasons.Range("A2:A" & WorksheetFunction.Min(lastReasonsRow, 11))
.SeriesCollection(1).Values = wsReasons.Range("B2:B" & WorksheetFunction.Min(lastReasonsRow, 11))
.HasTitle = True
.ChartTitle.Text = "Топ причин ремонтов"
End With
End If
End Sub
Private Sub AggregateDESForDashboard(ByVal wsSrc As Worksheet, ByVal wsDash As Worksheet)
Dim dict As Object, r As Long, lastRowVal As Long, blockName As String
Dim arr As Variant, outRow As Long, keys As Variant, i As Long
Dim mn As Double, mx As Double, avgV As Double, outputV As Double, fuelV As Double
Set dict = CreateObject("Scripting.Dictionary")
lastRowVal = LastRow(wsSrc)
wsDash.Range("J2:O200").Clear
wsDash.Range("J2:O2").Value = Array("Блок", "Мин", "Сред", "Макс", "Выработка", "Топливо ДЭС")
For r = 2 To lastRowVal
blockName = Trim$(CStr(wsSrc.Cells(r, 2).Value))
If blockName <> "" Then
mn = ToNumber(wsSrc.Cells(r, 3).Value)
mx = ToNumber(wsSrc.Cells(r, 4).Value)
avgV = ToNumber(wsSrc.Cells(r, 5).Value)
outputV = ToNumber(wsSrc.Cells(r, 7).Value)
fuelV = ToNumber(wsSrc.Cells(r, 8).Value)
If dict.Exists(blockName) Then
arr = dict(blockName)
If arr(1) = 0 Or (mn > 0 And mn < arr(1)) Then arr(1) = mn
If mx > arr(3) Then arr(3) = mx
arr(2) = arr(2) + avgV
arr(4) = arr(4) + outputV
arr(5) = arr(5) + fuelV
arr(6) = arr(6) + 1
Else
ReDim arr(1 To 6)
arr(1) = mn
arr(2) = avgV
arr(3) = mx
arr(4) = outputV
arr(5) = fuelV
arr(6) = 1
End If
dict(blockName) = arr
End If
Next r
keys = dict.Keys
SortStringKeys keys
outRow = 3
For i = LBound(keys) To UBound(keys)
arr = dict(keys(i))
wsDash.Cells(outRow, 10).Value = keys(i)
wsDash.Cells(outRow, 11).Value = arr(1)
wsDash.Cells(outRow, 12).Value = arr(2) / arr(6)
wsDash.Cells(outRow, 13).Value = arr(3)
wsDash.Cells(outRow, 14).Value = arr(4)
wsDash.Cells(outRow, 15).Value = arr(5)
outRow = outRow + 1
Next i
End Sub
Private Sub AggregateBoilersForDashboard(ByVal wsSrc As Worksheet, ByVal wsDash As Worksheet)
Dim dict As Object, r As Long, lastRowVal As Long, blockName As String
Dim arr As Variant, outRow As Long, keys As Variant, i As Long
Dim mn As Double, mx As Double, avgV As Double, sumV As Double
Set dict = CreateObject("Scripting.Dictionary")
lastRowVal = LastRow(wsSrc)
wsDash.Range("J40:N250").Clear
wsDash.Range("J40:N40").Value = Array("Блок", "Мин", "Сред", "Макс", "Сумма")
For r = 2 To lastRowVal
blockName = Trim$(CStr(wsSrc.Cells(r, 2).Value))
If blockName <> "" Then
mn = ToNumber(wsSrc.Cells(r, 3).Value)
mx = ToNumber(wsSrc.Cells(r, 4).Value)
avgV = ToNumber(wsSrc.Cells(r, 5).Value)
sumV = ToNumber(wsSrc.Cells(r, 6).Value)
If dict.Exists(blockName) Then
arr = dict(blockName)
If arr(1) = 0 Or (mn > 0 And mn < arr(1)) Then arr(1) = mn
If mx > arr(3) Then arr(3) = mx
arr(2) = arr(2) + avgV
arr(4) = arr(4) + sumV
arr(5) = arr(5) + 1
Else
ReDim arr(1 To 5)
arr(1) = mn
arr(2) = avgV
arr(3) = mx
arr(4) = sumV
arr(5) = 1
End If
dict(blockName) = arr
End If
Next r
keys = dict.Keys
SortStringKeys keys
outRow = 41
For i = LBound(keys) To UBound(keys)
arr = dict(keys(i))
wsDash.Cells(outRow, 10).Value = keys(i)
wsDash.Cells(outRow, 11).Value = arr(1)
wsDash.Cells(outRow, 12).Value = arr(2) / arr(5)
wsDash.Cells(outRow, 13).Value = arr(3)
wsDash.Cells(outRow, 14).Value = arr(4)
outRow = outRow + 1
Next i
End Sub
' =========================
' ОФОРМЛЕНИЕ
' =========================
Private Sub FormatSheets(ByVal wsSummary As Worksheet, ByVal wsRepairs As Worksheet, ByVal wsReasons As Worksheet, ByVal wsFiles As Worksheet, ByVal wsDash As Worksheet, ByVal wsDES As Worksheet, ByVal wsBoil As Worksheet)
FormatOneSheet wsSummary
FormatOneSheet wsRepairs
FormatOneSheet wsReasons
FormatOneSheet wsFiles
FormatOneSheet wsDES
FormatOneSheet wsBoil
wsSummary.Columns("A").NumberFormat = "dd.mm.yyyy"
wsRepairs.Columns("A").NumberFormat = "dd.mm.yyyy"
wsFiles.Columns("B").NumberFormat = "dd.mm.yyyy"
wsDES.Columns("A").NumberFormat = "dd.mm.yyyy"
wsBoil.Columns("A").NumberFormat = "dd.mm.yyyy"
wsDash.Columns("A:F").ColumnWidth = 16
wsDash.Columns("J:O").EntireColumn.AutoFit
wsDash.Range("A3:E7").Font.Bold = True
End Sub
Private Sub FormatOneSheet(ByVal ws As Worksheet)
With ws.Rows(1)
.Font.Bold = True
.Interior.Color = RGB(217, 225, 242)
End With
ws.Cells.EntireColumn.AutoFit
On Error Resume Next
ws.Rows(1).AutoFilter
On Error GoTo 0
End Sub
' =========================
' УТИЛИТЫ
' =========================
Private Function GetOrCreateSheet(ByVal sheetName As String) As Worksheet
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If LCase$(ws.Name) = LCase$(sheetName) Then
Set GetOrCreateSheet = ws
Exit Function
End If
Next ws
Set ws = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
ws.Name = Left$(sheetName, 31)
Set GetOrCreateSheet = ws
End Function
Private Function ExtractDateFromFileName(ByVal fileName As String) As Variant
Dim re As Object, m As Object
Dim d As Integer, mn As Integer, y As Integer
Set re = CreateObject("VBScript.RegExp")
re.Global = False
re.IgnoreCase = True
re.Pattern = "(\d{1,2})[.\-_](\d{1,2})[.\-_](\d{4})"
If re.Test(fileName) Then
Set m = re.Execute(fileName)(0)
d = CInt(m.SubMatches(0))
mn = CInt(m.SubMatches(1))
y = CInt(m.SubMatches(2))
ExtractDateFromFileName = DateSerial(y, mn, d)
Else
ExtractDateFromFileName = Empty
End If
End Function
Private Function LastRow(ByVal ws As Worksheet) As Long
Dim f As Range
On Error Resume Next
Set f = ws.Cells.Find(What:="*", After:=ws.Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
On Error GoTo 0
If f Is Nothing Then
LastRow = 1
Else
LastRow = f.Row
End If
End Function
Private Function ToNumber(ByVal v As Variant) As Double
Dim s As String
If IsNumeric(v) Then
ToNumber = CDbl(v)
Exit Function
End If
s = Trim$(CStr(v))
If s = "" Or s = "-" Then Exit Function
s = Replace(s, Chr(160), "")
s = Replace(s, " ", "")
s = Replace(s, "кВт", "", , , vbTextCompare)
s = Replace(s, "квт", "", , , vbTextCompare)
s = Replace(s, "л.", "", , , vbTextCompare)
s = Replace(s, "л", "", , , vbTextCompare)
s = Replace(s, "м³", "", , , vbTextCompare)
s = Replace(s, "м3", "", , , vbTextCompare)
s = Replace(s, ",", ".")
If IsNumeric(s) Then ToNumber = CDbl(s)
End Function
Private Function RowText(ByVal ws As Worksheet, ByVal r As Long) As String
Dim lastCol As Long, c As Long
Dim s As String, v As String
lastCol = ws.Cells(r, ws.Columns.Count).End(xlToLeft).Column
For c = 1 To lastCol
v = Trim$(CStr(ws.Cells(r, c).Text))
If v <> "" Then s = s & " " & v
Next c
RowText = Trim$(s)
End Function
Private Function CountNumericInRange(ByVal ws As Worksheet, ByVal r As Long, ByVal c1 As Long, ByVal c2 As Long) As Long
Dim c As Long
For c = c1 To c2
If ToNumber(ws.Cells(r, c).Value) <> 0 Then CountNumericInRange = CountNumericInRange + 1
Next c
End Function
Private Sub LogFile(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal fileName As String, ByVal dt As Variant, ByVal statusText As String, ByVal commentText As String)
ws.Cells(rowNum, 1).Value = fileName
If IsDate(dt) Then ws.Cells(rowNum, 2).Value = CDate(dt)
ws.Cells(rowNum, 3).Value = statusText
ws.Cells(rowNum, 4).Value = commentText
End Sub
Private Sub ClearSeries(ByVal ch As Chart)
On Error Resume Next
Do While ch.SeriesCollection.Count > 0
ch.SeriesCollection(1).Delete
Loop
On Error GoTo 0
End Sub
Private Sub DeleteAllCharts(ByVal ws As Worksheet)
Dim i As Long
For i = ws.ChartObjects.Count To 1 Step -1
ws.ChartObjects(i).Delete
Next i
End Sub
Private Sub SortDateKeys(ByRef arr As Variant)
Dim i As Long, j As Long, tmp As Variant
For i = LBound(arr) To UBound(arr) - 1
For j = i + 1 To UBound(arr)
If CDate(arr(j)) < CDate(arr(i)) Then
tmp = arr(i)
arr(i) = arr(j)
arr(j) = tmp
End If
Next j
Next i
End Sub
Private Sub SortStringKeys(ByRef arr As Variant)
Dim i As Long, j As Long, tmp As Variant
For i = LBound(arr) To UBound(arr) - 1
For j = i + 1 To UBound(arr)
If CStr(arr(j)) < CStr(arr(i)) Then
tmp = arr(i)
arr(i) = arr(j)
arr(j) = tmp
End If
Next j
Next i
End Sub