https://pastein.ru/t/zDy
Загрузка данных
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_DESNP As String = "ДЭС_НП"
Private Const REPORT_SHEET_BOILNP 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
Private Const DES_COL_STATE_RESERVE As Long = 9
Private Const DES_COL_STATE_REPAIR As Long = 10
Private Const DES_COL_NAME As Long = 11 ' K
Private Const DES_COL_LOAD_DAY As Long = 20 ' T = max за сутки
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 gDESLocality As Object
Private gBoilerLocality As Object
Public Sub ОбновитьДанные()
Dim folderPath As String
Dim fileName As String
Dim fullPath As String
Dim wb As Workbook
Dim wsDash As Worksheet, wsSummary As Worksheet, wsRepairs As Worksheet
Dim wsReasons As Worksheet, wsFiles As Worksheet
Dim wsDESNP As Worksheet, wsBoilNP As Worksheet
Dim dictSummary As Object, dictReasons As Object
Dim repairsRow As Long, filesRow As Long
Dim reportName As String
Dim dt As Variant
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 gDESLocality = CreateObject("Scripting.Dictionary")
Set gBoilerLocality = CreateObject("Scripting.Dictionary")
ПодготовитьЛисты wsDash, wsSummary, wsRepairs, wsReasons, wsFiles, wsDESNP, wsBoilNP
repairsRow = 2
filesRow = 2
fileName = Dir(folderPath & "\*.xls*")
Do While fileName <> ""
If LCase$(fileName) <> LCase$(reportName) Then
If Left$(fileName, 2) <> "~$" Then
fullPath = folderPath & "\" & fileName
dt = ИзвлечьДатуИзИмениФайла(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
ОбработатьКнигу wb, CDate(dt), fileName, dictSummary, dictReasons, wsRepairs, repairsRow, wsFiles, filesRow
wb.Close SaveChanges:=False
Set wb = Nothing
Else
ЗаписатьФайл wsFiles, filesRow, fileName, CDate(dt), "Ошибка", "Не удалось открыть файл"
filesRow = filesRow + 1
End If
Else
ЗаписатьФайл wsFiles, filesRow, fileName, Empty, "Пропущен", "Не найдена дата в имени файла"
filesRow = filesRow + 1
End If
End If
End If
fileName = Dir
Loop
ВыгрузитьСводку wsSummary, dictSummary
ВыгрузитьПричины wsReasons, dictReasons
ВыгрузитьДЭСПоНП wsDESNP, gDESLocality
ВыгрузитьКотельныеПоНП wsBoilNP, gBoilerLocality
ПостроитьДашборд wsDash, wsSummary, wsReasons, wsFiles, wsDESNP, wsBoilNP
ОформитьЛисты wsSummary, wsRepairs, wsReasons, wsFiles, wsDash, wsDESNP, wsBoilNP
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 = ПолучитьИлиСоздатьЛист(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 ПодготовитьЛисты(ByRef wsDash As Worksheet, ByRef wsSummary As Worksheet, ByRef wsRepairs As Worksheet, ByRef wsReasons As Worksheet, ByRef wsFiles As Worksheet, ByRef wsDESNP As Worksheet, ByRef wsBoilNP As Worksheet)
Set wsDash = ПолучитьИлиСоздатьЛист(REPORT_SHEET_DASH)
Set wsSummary = ПолучитьИлиСоздатьЛист(REPORT_SHEET_SUMMARY)
Set wsRepairs = ПолучитьИлиСоздатьЛист(REPORT_SHEET_REPAIRS)
Set wsReasons = ПолучитьИлиСоздатьЛист(REPORT_SHEET_REASONS)
Set wsFiles = ПолучитьИлиСоздатьЛист(REPORT_SHEET_FILES)
Set wsDESNP = ПолучитьИлиСоздатьЛист(REPORT_SHEET_DESNP)
Set wsBoilNP = ПолучитьИлиСоздатьЛист(REPORT_SHEET_BOILNP)
wsDash.Cells.Clear
wsSummary.Cells.Clear
wsRepairs.Cells.Clear
wsReasons.Cells.Clear
wsFiles.Cells.Clear
wsDESNP.Cells.Clear
wsBoilNP.Cells.Clear
wsSummary.Range("A1:M1").Value = Array( _
"Дата", "Файлов", "Ремонтов", "Нагрузка ДЭС, кВт", "Выработка ДЭС, кВт", _
"Топливо ДЭС, л", "Топливо котельных, м³", "Общее топливо", _
"ДГУ в работе", "ДГУ в резерве", "ДГУ в ремонте", "Кол-во причин", "Расход масла ДЭС")
wsRepairs.Range("A1:F1").Value = Array("Дата", "Источник", "Объект/оборудование", "Причина", "Примечание", "Исходный файл")
wsReasons.Range("A1:B1").Value = Array("Причина", "Количество")
wsFiles.Range("A1:D1").Value = Array("Файл", "Дата", "Статус", "Комментарий")
wsDESNP.Range("A1:I1").Value = Array( _
"Дата", "Населенный пункт", "Нагрузка мин", "Нагрузка макс", _
"Нагрузка сумма", "Выработка", "Топливо ДЭС", "Масло ДЭС", "Кол-во установок")
wsBoilNP.Range("A1:D1").Value = Array("Дата", "Населенный пункт", "Топливо котельных", "Кол-во объектов")
End Sub
Private Sub ОбработатьКнигу(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 = СчитатьДЭСНагрузкуИСтатусыИНП(wb, dt, cntWork, cntReserve, cntRepairState)
desOutput = СчитатьВыработкуДЭСИОбновитьНП(wb, dt)
desFuel = СчитатьТопливоДЭСИОбновитьНП(wb, dt)
desOil = СчитатьМаслоДЭСИОбновитьНП(wb, dt)
boilersFuel = СчитатьТопливоКотельныхИНП(wb, dt)
totalFuel = desFuel + boilersFuel
cntRepairs = СчитатьРемонты(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
ДобавитьВСводку dictSummary, dt, 1, cntRepairs, desLoad, desOutput, desFuel, boilersFuel, totalFuel, cntWork, cntReserve, cntRepairState, desOil
If okAny Then
ЗаписатьФайл wsFiles, filesRow, fileName, dt, "ОК", "Обработан"
Else
ЗаписатьФайл wsFiles, filesRow, fileName, dt, "ОК", "Файл открыт, но данные не распознаны"
End If
filesRow = filesRow + 1
End Sub
Private Function СчитатьДЭСНагрузкуИСтатусыИНП(ByVal wb As Workbook, ByVal dt As Date, ByRef cntWork As Long, ByRef cntReserve As Long, ByRef cntRepairState As Long) As Double
Dim ws As Worksheet
Dim lastRow As Long, r As Long
Dim totalLoad As Double
Dim vRun As Variant, vReserve As Variant, vRepair As Variant, vLoad As Variant
Dim np As String
On Error Resume Next
Set ws = wb.Worksheets(SRC_SHEET_DES)
On Error GoTo 0
If ws Is Nothing Then Exit Function
lastRow = ПоследняяСтрока(ws)
totalLoad = 0
np = ""
For r = 1 To lastRow
If ЭтоЗаголовокНПДЭС(ws, r) Then
np = НормализоватьНП(ТекстСтроки(ws, r))
ElseIf ЭтоСтрокаДЭС(ws, r) Then
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
vLoad = ws.Cells(r, DES_COL_LOAD_DAY).Value
If Trim$(CStr(vRun)) = "+" Then cntWork = cntWork + 1
If Trim$(CStr(vReserve)) = "+" Then cntReserve = cntReserve + 1
If LCase$(Trim$(CStr(vRepair))) = "ремонт" Or Trim$(CStr(vRepair)) = "+" Then
cntRepairState = cntRepairState + 1
End If
totalLoad = totalLoad + ЧислоИзЯчейки(vLoad)
ОбновитьДЭСНП dt, np, ЧислоИзЯчейки(vLoad), 0, 0, 0
End If
Next r
СчитатьДЭСНагрузкуИСтатусыИНП = totalLoad
End Function
Private Function СчитатьВыработкуДЭСИОбновитьНП(ByVal wb As Workbook, ByVal dt As Date) As Double
Dim ws As Worksheet
Dim lastRow As Long, r As Long
Dim totalOutput As Double
Dim v As Variant, np As String
On Error Resume Next
Set ws = wb.Worksheets(SRC_SHEET_DES)
On Error GoTo 0
If ws Is Nothing Then Exit Function
lastRow = ПоследняяСтрока(ws)
totalOutput = 0
np = ""
For r = 1 To lastRow
If ЭтоЗаголовокНПДЭС(ws, r) Then
np = НормализоватьНП(ТекстСтроки(ws, r))
ElseIf ЭтоСтрокаДЭС(ws, r) Then
v = ws.Cells(r, DES_COL_OUTPUT).Value
totalOutput = totalOutput + ЧислоИзЯчейки(v)
ОбновитьДЭСНП dt, np, 0, ЧислоИзЯчейки(v), 0, 0
End If
Next r
СчитатьВыработкуДЭСИОбновитьНП = totalOutput
End Function
Private Function СчитатьТопливоДЭСИОбновитьНП(ByVal wb As Workbook, ByVal dt As Date) As Double
Dim ws As Worksheet
Dim lastRow As Long, r As Long
Dim totalFuel As Double
Dim v As Variant, np As String
On Error Resume Next
Set ws = wb.Worksheets(SRC_SHEET_DES)
On Error GoTo 0
If ws Is Nothing Then Exit Function
lastRow = ПоследняяСтрока(ws)
totalFuel = 0
np = ""
For r = 1 To lastRow
If ЭтоЗаголовокНПДЭС(ws, r) Then
np = НормализоватьНП(ТекстСтроки(ws, r))
ElseIf ЭтоСтрокаДЭС(ws, r) Then
v = ws.Cells(r, DES_COL_FUEL).Value
totalFuel = totalFuel + ЧислоИзЯчейки(v)
ОбновитьДЭСНП dt, np, 0, 0, ЧислоИзЯчейки(v), 0
End If
Next r
СчитатьТопливоДЭСИОбновитьНП = totalFuel
End Function
Private Function СчитатьМаслоДЭСИОбновитьНП(ByVal wb As Workbook, ByVal dt As Date) As Double
Dim ws As Worksheet
Dim lastRow As Long, r As Long
Dim totalOil As Double
Dim v As Variant, np As String
On Error Resume Next
Set ws = wb.Worksheets(SRC_SHEET_DES)
On Error GoTo 0
If ws Is Nothing Then Exit Function
lastRow = ПоследняяСтрока(ws)
totalOil = 0
np = ""
For r = 1 To lastRow
If ЭтоЗаголовокНПДЭС(ws, r) Then
np = НормализоватьНП(ТекстСтроки(ws, r))
ElseIf ЭтоСтрокаДЭС(ws, r) Then
v = ws.Cells(r, DES_COL_OIL).Value
totalOil = totalOil + ЧислоИзЯчейки(v)
ОбновитьДЭСНП dt, np, 0, 0, 0, ЧислоИзЯчейки(v)
End If
Next r
СчитатьМаслоДЭСИОбновитьНП = totalOil
End Function
Private Function СчитатьТопливоКотельныхИНП(ByVal wb As Workbook, ByVal dt As Date) As Double
Dim ws As Worksheet
Dim lastRow As Long, r As Long
Dim totalFuel As Double
Dim fuelCol As Long
Dim v As Variant, np As String
On Error Resume Next
Set ws = wb.Worksheets(SRC_SHEET_BOILERS)
On Error GoTo 0
If ws Is Nothing Then Exit Function
fuelCol = НайтиКолонкуТопливаКотельных(ws)
lastRow = ПоследняяСтрока(ws)
totalFuel = 0
np = ""
For r = 1 To lastRow
If ЭтоЗаголовокНПКотельных(ws, r) Then
np = НормализоватьНП(ТекстСтроки(ws, r))
ElseIf ЭтоСтрокаКотельной(ws, r) Then
v = ws.Cells(r, fuelCol).Value
totalFuel = totalFuel + ЧислоИзЯчейки(v)
ОбновитьКотельныеНП dt, np, ЧислоИзЯчейки(v)
End If
Next r
СчитатьТопливоКотельныхИНП = totalFuel
End Function
Private Function СчитатьРемонты(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
Dim 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 = ПоследняяСтрока(ws)
cnt = 0
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
repairsRow = repairsRow + 1
cnt = cnt + 1
If dictReasons.Exists(reasonVal) Then
dictReasons(reasonVal) = CLng(dictReasons(reasonVal)) + 1
Else
dictReasons.Add reasonVal, 1
End If
End If
Next r
СчитатьРемонты = cnt
End Function
Private Sub ДобавитьВСводку(ByVal dictSummary As Object, ByVal dt As Date, ByVal fileCount As Long, ByVal repairCount As Long, ByVal desLoad As Double, ByVal desOutput As Double, ByVal desFuel As Double, ByVal boilersFuel As Double, ByVal totalFuel As Double, ByVal workCnt As Long, ByVal reserveCnt As Long, ByVal repairStateCnt As Long, ByVal desOil As Double)
Dim key As String
Dim arr As Variant
key = Format$(dt, "yyyy-mm-dd")
If dictSummary.Exists(key) Then
arr = dictSummary(key)
Else
ReDim arr(1 To 12)
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
arr(11) = 0
arr(12) = 0#
End If
arr(1) = arr(1) + fileCount
arr(2) = arr(2) + repairCount
arr(3) = arr(3) + desLoad
arr(4) = arr(4) + desOutput
arr(5) = arr(5) + desFuel
arr(6) = arr(6) + boilersFuel
arr(7) = arr(7) + totalFuel
arr(8) = arr(8) + workCnt
arr(9) = arr(9) + reserveCnt
arr(10) = arr(10) + repairStateCnt
arr(11) = arr(11) + 0
arr(12) = arr(12) + desOil
dictSummary(key) = arr
End Sub
Private Sub ВыгрузитьСводку(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
ОтсортироватьДаты 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 ВыгрузитьПричины(ByVal ws As Worksheet, ByVal dictReasons As Object)
Dim keys As Variant, i As Long, r As Long
Dim lastRow 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
lastRow = ПоследняяСтрока(ws)
If lastRow >= 2 Then
ws.Range("A1:B" & lastRow).Sort Key1:=ws.Range("B2"), Order1:=xlDescending, Header:=xlYes
End If
End Sub
Private Sub ВыгрузитьДЭСПоНП(ByVal ws As Worksheet, ByVal dictData As Object)
Dim keys As Variant, i As Long, r As Long, arr As Variant, parts() As String
If dictData Is Nothing Then Exit Sub
If dictData.Count = 0 Then Exit Sub
keys = dictData.Keys
ОтсортироватьСтроки keys
r = 2
For i = LBound(keys) To UBound(keys)
arr = dictData(keys(i))
parts = Split(CStr(keys(i)), "|")
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 = arr(3)
ws.Cells(r, 6).Value = arr(4)
ws.Cells(r, 7).Value = arr(5)
ws.Cells(r, 8).Value = arr(6)
ws.Cells(r, 9).Value = arr(7)
r = r + 1
Next i
End Sub
Private Sub ВыгрузитьКотельныеПоНП(ByVal ws As Worksheet, ByVal dictData As Object)
Dim keys As Variant, i As Long, r As Long, arr As Variant, parts() As String
If dictData Is Nothing Then Exit Sub
If dictData.Count = 0 Then Exit Sub
keys = dictData.Keys
ОтсортироватьСтроки keys
r = 2
For i = LBound(keys) To UBound(keys)
arr = dictData(keys(i))
parts = Split(CStr(keys(i)), "|")
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)
r = r + 1
Next i
End Sub
Private Sub ПостроитьДашборд(ByVal wsDash As Worksheet, ByVal wsSummary As Worksheet, ByVal wsReasons As Worksheet, ByVal wsFiles As Worksheet, ByVal wsDESNP As Worksheet, ByVal wsBoilNP As Worksheet)
Dim lastSummaryRow As Long, lastReasonsRow As Long, lastDESNPRow As Long, lastBoilNPRow As Long
Dim ch As ChartObject
Dim aggRow1 As Long, aggRow2 As Long
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 = ПоследняяСтрока(wsSummary)
lastReasonsRow = ПоследняяСтрока(wsReasons)
lastDESNPRow = ПоследняяСтрока(wsDESNP)
lastBoilNPRow = ПоследняяСтрока(wsBoilNP)
УдалитьВсеДиаграммы wsDash
If lastSummaryRow >= 2 Then
Set ch = wsDash.ChartObjects.Add(Left:=20, Top:=130, Width:=420, Height:=220)
With ch.Chart
.ChartType = xlColumnClustered
ОчиститьСерии 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
ОчиститьСерии 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 lastDESNPRow >= 2 Then
aggRow1 = 2
ПостроитьАгрегациюМаксМинНП wsDESNP, "A:I", "B", "C", "D", wsDash, aggRow1
Set ch = wsDash.ChartObjects.Add(Left:=20, Top:=380, Width:=860, Height:=260)
With ch.Chart
.ChartType = xlColumnClustered
ОчиститьСерии ch.Chart
.SeriesCollection.NewSeries
.SeriesCollection(1).Name = "=""Мин нагрузка"""
.SeriesCollection(1).XValues = wsDash.Range("J" & aggRow1 + 1 & ":J" & ПоследняяСтрока(wsDash))
.SeriesCollection(1).Values = wsDash.Range("K" & aggRow1 + 1 & ":K" & ПоследняяСтрока(wsDash))
.SeriesCollection.NewSeries
.SeriesCollection(2).Name = "=""Макс нагрузка"""
.SeriesCollection(2).XValues = wsDash.Range("J" & aggRow1 + 1 & ":J" & ПоследняяСтрока(wsDash))
.SeriesCollection(2).Values = wsDash.Range("L" & aggRow1 + 1 & ":L" & ПоследняяСтрока(wsDash))
.HasTitle = True
.ChartTitle.Text = "Минимум / максимум нагрузки ДЭС по населенным пунктам"
End With
End If
If lastBoilNPRow >= 2 Then
aggRow2 = 40
ПостроитьАгрегациюТопливаКотельных wsBoilNP, wsDash, aggRow2
Set ch = wsDash.ChartObjects.Add(Left:=20, Top:=670, Width:=860, Height:=260)
With ch.Chart
.ChartType = xlBarClustered
ОчиститьСерии ch.Chart
.SeriesCollection.NewSeries
.SeriesCollection(1).Name = "=""Топливо котельных"""
.SeriesCollection(1).XValues = wsDash.Range("J" & aggRow2 + 1 & ":J" & ПоследняяСтрока(wsDash))
.SeriesCollection(1).Values = wsDash.Range("K" & aggRow2 + 1 & ":K" & ПоследняяСтрока(wsDash))
.HasTitle = True
.ChartTitle.Text = "Топливо котельных по населенным пунктам"
End With
End If
If lastReasonsRow >= 2 Then
Set ch = wsDash.ChartObjects.Add(Left:=20, Top:=960, Width:=860, Height:=260)
With ch.Chart
.ChartType = xlBarClustered
ОчиститьСерии 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 ПостроитьАгрегациюМаксМинНП(ByVal wsSrc As Worksheet, ByVal rngAll As String, ByVal colNP As String, ByVal colMin As String, ByVal colMax As String, ByVal wsDash As Worksheet, ByVal startRow As Long)
Dim dict As Object, r As Long, lastRow As Long, np As String
Dim arr As Variant, outRow As Long, keys As Variant, i As Long
Dim mn As Double, mx As Double
Set dict = CreateObject("Scripting.Dictionary")
lastRow = ПоследняяСтрока(wsSrc)
wsDash.Range("J" & startRow & ":L200").Clear
wsDash.Cells(startRow, 10).Value = "Населенный пункт"
wsDash.Cells(startRow, 11).Value = "Мин"
wsDash.Cells(startRow, 12).Value = "Макс"
For r = 2 To lastRow
np = Trim$(CStr(wsSrc.Cells(r, 2).Value))
If np <> "" Then
mn = ЧислоИзЯчейки(wsSrc.Cells(r, 3).Value)
mx = ЧислоИзЯчейки(wsSrc.Cells(r, 4).Value)
If dict.Exists(np) Then
arr = dict(np)
If mn < arr(1) Then arr(1) = mn
If mx > arr(2) Then arr(2) = mx
Else
ReDim arr(1 To 2)
arr(1) = mn
arr(2) = mx
End If
dict(np) = arr
End If
Next r
keys = dict.Keys
outRow = startRow + 1
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)
outRow = outRow + 1
Next i
End Sub
Private Sub ПостроитьАгрегациюТопливаКотельных(ByVal wsSrc As Worksheet, ByVal wsDash As Worksheet, ByVal startRow As Long)
Dim dict As Object, r As Long, lastRow As Long, np As String
Dim outRow As Long, keys As Variant, i As Long
Set dict = CreateObject("Scripting.Dictionary")
lastRow = ПоследняяСтрока(wsSrc)
wsDash.Range("J" & startRow & ":K250").Clear
wsDash.Cells(startRow, 10).Value = "Населенный пункт"
wsDash.Cells(startRow, 11).Value = "Топливо"
For r = 2 To lastRow
np = Trim$(CStr(wsSrc.Cells(r, 2).Value))
If np <> "" Then
If dict.Exists(np) Then
dict(np) = dict(np) + ЧислоИзЯчейки(wsSrc.Cells(r, 3).Value)
Else
dict.Add np, ЧислоИзЯчейки(wsSrc.Cells(r, 3).Value)
End If
End If
Next r
keys = dict.Keys
outRow = startRow + 1
For i = LBound(keys) To UBound(keys)
wsDash.Cells(outRow, 10).Value = keys(i)
wsDash.Cells(outRow, 11).Value = dict(keys(i))
outRow = outRow + 1
Next i
End Sub
Private Sub ОформитьЛисты(ByVal wsSummary As Worksheet, ByVal wsRepairs As Worksheet, ByVal wsReasons As Worksheet, ByVal wsFiles As Worksheet, ByVal wsDash As Worksheet, ByVal wsDESNP As Worksheet, ByVal wsBoilNP As Worksheet)
ОформитьОдинЛист wsSummary
ОформитьОдинЛист wsRepairs
ОформитьОдинЛист wsReasons
ОформитьОдинЛист wsFiles
ОформитьОдинЛист wsDESNP
ОформитьОдинЛист wsBoilNP
wsSummary.Columns("A").NumberFormat = "dd.mm.yyyy"
wsRepairs.Columns("A").NumberFormat = "dd.mm.yyyy"
wsFiles.Columns("B").NumberFormat = "dd.mm.yyyy"
wsDESNP.Columns("A").NumberFormat = "dd.mm.yyyy"
wsBoilNP.Columns("A").NumberFormat = "dd.mm.yyyy"
wsDash.Columns("A:F").ColumnWidth = 16
wsDash.Columns("J:L").EntireColumn.AutoFit
wsDash.Range("A3:E7").Font.Bold = True
End Sub
Private Sub ОформитьОдинЛист(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 Sub ЗаписатьФайл(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 Function ПолучитьИлиСоздатьЛист(ByVal sheetName As String) As Worksheet
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If LCase$(ws.Name) = LCase$(sheetName) Then
Set ПолучитьИлиСоздатьЛист = ws
Exit Function
End If
Next ws
Set ws = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
ws.Name = Left$(sheetName, 31)
Set ПолучитьИлиСоздатьЛист = ws
End Function
Private Function ИзвлечьДатуИзИмениФайла(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))
ИзвлечьДатуИзИмениФайла = DateSerial(y, mn, d)
Else
ИзвлечьДатуИзИмениФайла = Empty
End If
End Function
Private Function ПоследняяСтрока(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
ПоследняяСтрока = 1
Else
ПоследняяСтрока = f.Row
End If
End Function
Private Function ЧислоИзЯчейки(ByVal v As Variant) As Double
Dim s As String
If IsNumeric(v) Then
ЧислоИзЯчейки = 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
ЧислоИзЯчейки = CDbl(s)
End If
End Function
Private Function ЭтоСтрокаДЭС(ByVal ws As Worksheet, ByVal r As Long) As Boolean
Dim nm As String
nm = Trim$(CStr(ws.Cells(r, DES_COL_NAME).Value))
If nm = "" 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 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 Then
ЭтоСтрокаДЭС = True
End If
End Function
Private Function ЭтоЗаголовокНПДЭС(ByVal ws As Worksheet, ByVal r As Long) As Boolean
Dim txt As String
txt = ТекстСтроки(ws, r)
If InStr(1, txt, "ДЭС-", vbTextCompare) > 0 _
Or InStr(1, txt, "ГПТЭС", vbTextCompare) > 0 _
Or InStr(1, txt, "ул.", vbTextCompare) > 0 Then
ЭтоЗаголовокНПДЭС = True
End If
End Function
Private Function ЭтоЗаголовокНПКотельных(ByVal ws As Worksheet, ByVal r As Long) As Boolean
Dim txt As String
txt = ТекстСтроки(ws, r)
If InStr(1, txt, "№", vbTextCompare) > 0 And InStr(1, txt, "ул.", vbTextCompare) > 0 Then
ЭтоЗаголовокНПКотельных = True
End If
End Function
Private Function ЭтоСтрокаКотельной(ByVal ws As Worksheet, ByVal r As Long) As Boolean
Dim txt As String
txt = ТекстСтроки(ws, r)
If txt = "" Then Exit Function
If InStr(1, txt, "ул.", vbTextCompare) > 0 Then Exit Function
If InStr(1, LCase$(txt), "итого", vbTextCompare) > 0 Then Exit Function
If WorksheetFunction.CountA(ws.Rows(r)) > 3 Then ЭтоСтрокаКотельной = True
End Function
Private Function НайтиКолонкуТопливаКотельных(ByVal ws As Worksheet) As Long
Dim r As Long, c As Long, lastCol As Long
Dim txt As String
For r = 1 To 10
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
НайтиКолонкуТопливаКотельных = c
Exit Function
End If
End If
Next c
Next r
НайтиКолонкуТопливаКотельных = 20
End Function
Private Function ТекстСтроки(ByVal ws As Worksheet, ByVal r As Long) As String
Dim lastCol As Long, c As Long, 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
ТекстСтроки = Trim$(s)
End Function
Private Function НормализоватьНП(ByVal txt As String) As String
Dim p As Long, s As String
s = txt
p = InStr(1, s, " ул.", vbTextCompare)
If p > 0 Then s = Left$(s, p - 1)
s = Replace(s, "ДЭС-", "")
s = Replace(s, "ГПТЭС", "")
s = Replace(s, "№", "")
s = Trim$(s)
If s = "" Then s = "Не определено"
НормализоватьНП = s
End Function
Private Sub ОбновитьДЭСНП(ByVal dt As Date, ByVal np As String, ByVal loadVal As Double, ByVal outputVal As Double, ByVal fuelVal As Double, ByVal oilVal As Double)
Dim key As String, arr As Variant
If np = "" Then np = "Не определено"
key = Format$(dt, "yyyy-mm-dd") & "|" & np
If gDESLocality.Exists(key) Then
arr = gDESLocality(key)
Else
ReDim arr(1 To 7)
arr(1) = 1E+30 ' min
arr(2) = 0# ' max
arr(3) = 0# ' sum load
arr(4) = 0# ' output
arr(5) = 0# ' fuel
arr(6) = 0# ' oil
arr(7) = 0 ' count
End If
If loadVal > 0 Then
If 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
If arr(1) = 1E+30 Then arr(1) = 0
gDESLocality(key) = arr
End Sub
Private Sub ОбновитьКотельныеНП(ByVal dt As Date, ByVal np As String, ByVal fuelVal As Double)
Dim key As String, arr As Variant
If np = "" Then np = "Не определено"
key = Format$(dt, "yyyy-mm-dd") & "|" & np
If gBoilerLocality.Exists(key) Then
arr = gBoilerLocality(key)
Else
ReDim arr(1 To 2)
arr(1) = 0#
arr(2) = 0
End If
arr(1) = arr(1) + fuelVal
If fuelVal <> 0 Then arr(2) = arr(2) + 1
gBoilerLocality(key) = arr
End Sub
Private Sub ОчиститьСерии(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 УдалитьВсеДиаграммы(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 ОтсортироватьДаты(ByRef arr As Variant)
Dim i As Long, j As Long
Dim 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 ОтсортироватьСтроки(ByRef arr As Variant)
Dim i As Long, j As Long
Dim 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