---

Option Explicit

Public Sub RefreshMonthData()
    Dim folderPath As String
    Dim fileName As String
    Dim fullPath As String
    Dim wb As Workbook
    Dim wsSummary As Worksheet, wsRepairs As Worksheet, wsReasons As Worksheet
    Dim wsFiles As Worksheet, wsDash As Worksheet
    Dim dictSummary As Object, dictReasons As Object
    Dim repairsRow As Long, filesRow As Long
    Dim reportName As String
    Dim dt As Variant
    Dim openedHere As Boolean
    
    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")
    
    PrepareSheets wsDash, wsSummary, wsRepairs, wsReasons, wsFiles
    
    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 = ExtractDateFromFilename(fileName)
                
                If IsDate(dt) Then
                    openedHere = False
                    
                    On Error Resume Next
                    Set wb = Workbooks.Open(Filename:=fullPath, ReadOnly:=True, UpdateLinks:=False, IgnoreReadOnlyRecommended:=True)
                    If Err.Number = 0 Then
                        openedHere = True
                    End If
                    On Error GoTo EH
                    
                    If Not wb Is Nothing Then
                        ProcessWorkbook wb, CDate(dt), fileName, dictSummary, dictReasons, wsRepairs, repairsRow, wsFiles, filesRow
                        
                        If openedHere Then
                            wb.Close SaveChanges:=False
                        End If
                        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
        End If
        fileName = Dir
    Loop
    
    WriteSummary wsSummary, dictSummary
    WriteReasons wsReasons, dictReasons
    BuildDashboard wsDash, wsSummary, wsReasons, wsFiles
    
    FormatSheets wsSummary, wsRepairs, wsReasons, wsFiles, wsDash
    
    Application.StatusBar = False
    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

Private Sub PrepareSheets(ByRef wsDash As Worksheet, ByRef wsSummary As Worksheet, ByRef wsRepairs As Worksheet, ByRef wsReasons As Worksheet, ByRef wsFiles As Worksheet)
    Set wsDash = GetOrCreateSheet("Дашборд")
    Set wsSummary = GetOrCreateSheet("Сводка по дням")
    Set wsRepairs = GetOrCreateSheet("Ремонты")
    Set wsReasons = GetOrCreateSheet("Причины")
    Set wsFiles = GetOrCreateSheet("Файлы")
    
    wsDash.Cells.Clear
    wsSummary.Cells.Clear
    wsRepairs.Cells.Clear
    wsReasons.Cells.Clear
    wsFiles.Cells.Clear
    
    wsSummary.Range("A1:H1").Value = Array("Дата", "Файлов", "Ремонтов", "Выработка ДЭС", "Расход топлива котельные", "ДГУ в работе", "ДГУ в резерве", "ДГУ в ремонте")
    wsRepairs.Range("A1:F1").Value = Array("Дата", "Источник", "Объект/оборудование", "Причина", "Примечание", "Исходный файл")
    wsReasons.Range("A1:B1").Value = Array("Причина", "Количество")
    wsFiles.Range("A1:D1").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 sumGeneration As Double, sumFuel As Double
    Dim cntRepairs As Long, cntWork As Long, cntReserve As Long, cntRepairState As Long
    Dim okAny As Boolean
    
    okAny = False
    
    sumGeneration = ReadDES(wb, cntWork, cntReserve, cntRepairState)
    If sumGeneration <> 0 Or cntWork <> 0 Or cntReserve <> 0 Or cntRepairState <> 0 Then okAny = True
    
    sumFuel = ReadBoilers(wb)
    If sumFuel <> 0 Then okAny = True
    
    cntRepairs = ReadRepairs(wb, dt, fileName, dictReasons, wsRepairs, repairsRow)
    If cntRepairs <> 0 Then okAny = True
    
    AddSummary dictSummary, dt, 1, cntRepairs, sumGeneration, sumFuel, cntWork, cntReserve, cntRepairState
    
    If okAny Then
        LogFile wsFiles, filesRow, fileName, dt, "ОК", "Обработан"
    Else
        LogFile wsFiles, filesRow, fileName, dt, "ОК", "Файл открыт, но данные не распознаны"
    End If
    filesRow = filesRow + 1
End Sub

Private Function ReadDES(ByVal wb As Workbook, ByRef cntWork As Long, ByRef cntReserve As Long, ByRef cntRepairState As Long) As Double
    Dim ws As Worksheet
    Dim headerRow As Long
    Dim genCol As Long, statusCol As Long
    Dim lastRow As Long, r As Long
    Dim v As Variant, txt As String
    Dim totalGen As Double
    
    On Error Resume Next
    Set ws = wb.Worksheets("ДЭС")
    On Error GoTo 0
    If ws Is Nothing Then Exit Function
    
    headerRow = FindHeaderRow(ws, Array("выработ", "состоя", "режим", "статус"))
    If headerRow = 0 Then headerRow = 1
    
    genCol = FindColumnByKeywords(ws, headerRow, Array("выработ"))
    statusCol = FindColumnByKeywords(ws, headerRow, Array("состоя", "режим", "статус"))
    
    lastRow = LastUsedRow(ws)
    totalGen = 0
    
    If genCol > 0 Then
        For r = headerRow + 1 To lastRow
            v = ws.Cells(r, genCol).Value
            If IsNumeric(v) Then totalGen = totalGen + CDbl(v)
        Next r
    End If
    
    If statusCol > 0 Then
        For r = headerRow + 1 To lastRow
            txt = LCase(Trim(CStr(ws.Cells(r, statusCol).Value)))
            If txt <> "" Then
                If InStr(txt, "работ") > 0 Then
                    cntWork = cntWork + 1
                ElseIf InStr(txt, "резерв") > 0 Then
                    cntReserve = cntReserve + 1
                ElseIf InStr(txt, "ремонт") > 0 Then
                    cntRepairState = cntRepairState + 1
                End If
            End If
        Next r
    End If
    
    ReadDES = totalGen
End Function

Private Function ReadBoilers(ByVal wb As Workbook) As Double
    Dim ws As Worksheet
    Dim headerRow As Long
    Dim fuelCol As Long
    Dim lastRow As Long, r As Long
    Dim v As Variant
    Dim totalFuel As Double
    
    On Error Resume Next
    Set ws = wb.Worksheets("Котельные")
    On Error GoTo 0
    If ws Is Nothing Then Exit Function
    
    headerRow = FindHeaderRow(ws, Array("расход", "топлив"))
    If headerRow = 0 Then headerRow = 1
    
    fuelCol = FindColumnByKeywords(ws, headerRow, Array("расход", "топлив"))
    If fuelCol = 0 Then fuelCol = FindColumnByKeywords(ws, headerRow, Array("топлив"))
    
    lastRow = LastUsedRow(ws)
    totalFuel = 0
    
    If fuelCol > 0 Then
        For r = headerRow + 1 To lastRow
            v = ws.Cells(r, fuelCol).Value
            If IsNumeric(v) Then totalFuel = totalFuel + CDbl(v)
        Next r
    End If
    
    ReadBoilers = totalFuel
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 headerRow As Long
    Dim objCol As Long, reasonCol As Long, noteCol As Long
    Dim lastRow As Long, r As Long
    Dim objVal As String, reasonVal As String, noteVal As String
    Dim cnt As Long
    
    On Error Resume Next
    Set ws = wb.Worksheets("Ремонт оборудования")
    On Error GoTo 0
    If ws Is Nothing Then Exit Function
    
    headerRow = FindHeaderRow(ws, Array("прич", "оборуд", "объект", "примеч"))
    If headerRow = 0 Then headerRow = 1
    
    objCol = FindColumnByKeywords(ws, headerRow, Array("оборуд", "объект", "наимен"))
    reasonCol = FindColumnByKeywords(ws, headerRow, Array("прич"))
    noteCol = FindColumnByKeywords(ws, headerRow, Array("примеч", "описан", "коммент"))
    
    lastRow = LastUsedRow(ws)
    cnt = 0
    
    For r = headerRow + 1 To lastRow
        objVal = ""
        reasonVal = ""
        noteVal = ""
        
        If objCol > 0 Then objVal = Trim(CStr(ws.Cells(r, objCol).Value))
        If reasonCol > 0 Then reasonVal = Trim(CStr(ws.Cells(r, reasonCol).Value))
        If noteCol > 0 Then noteVal = Trim(CStr(ws.Cells(r, noteCol).Value))
        
        If objVal <> "" Or reasonVal <> "" Or noteVal <> "" Then
            wsRepairs.Cells(repairsRow, 1).Value = dt
            wsRepairs.Cells(repairsRow, 2).Value = "Ремонт оборудования"
            wsRepairs.Cells(repairsRow, 3).Value = objVal
            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 reasonVal <> "" Then
                If dictReasons.Exists(reasonVal) Then
                    dictReasons(reasonVal) = CLng(dictReasons(reasonVal)) + 1
                Else
                    dictReasons.Add reasonVal, 1
                End If
            End If
        End If
    Next r
    
    ReadRepairs = cnt
End Function

Private Sub AddSummary(ByVal dictSummary As Object, ByVal dt As Date, ByVal fileCount As Long, ByVal repairCount As Long, ByVal generation As Double, ByVal fuel As Double, ByVal workCnt As Long, ByVal reserveCnt As Long, ByVal repairStateCnt As Long)
    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 7)
        arr(1) = 0
        arr(2) = 0
        arr(3) = 0#
        arr(4) = 0#
        arr(5) = 0
        arr(6) = 0
        arr(7) = 0
    End If
    
    arr(1) = arr(1) + fileCount
    arr(2) = arr(2) + repairCount
    arr(3) = arr(3) + generation
    arr(4) = arr(4) + fuel
    arr(5) = arr(5) + workCnt
    arr(6) = arr(6) + reserveCnt
    arr(7) = arr(7) + repairStateCnt
    
    dictSummary(key) = arr
End Sub

Private Sub WriteSummary(ByVal ws As Worksheet, ByVal dictSummary As Object)
    Dim keys As Variant, i As Long, r As Long, arr As Variant
    Dim temp As String
    
    If dictSummary.Count = 0 Then Exit Sub
    
    keys = dictSummary.Keys
    SortStringDates 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)
        r = r + 1
    Next i
End Sub

Private Sub WriteReasons(ByVal ws As Worksheet, ByVal dictReasons As Object)
    Dim keys As Variant, i As Long, r 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
    
    Dim lastRow As Long
    lastRow = LastUsedRow(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 BuildDashboard(ByVal wsDash As Worksheet, ByVal wsSummary As Worksheet, ByVal wsReasons As Worksheet, ByVal wsFiles As Worksheet)
    Dim lastSummaryRow As Long, lastReasonsRow As Long, lastFilesRow 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('Сводка по дням'!D:D)"
    
    wsDash.Range("A5").Value = "Расход топлива"
    wsDash.Range("B5").Formula = "=SUM('Сводка по дням'!E:E)"
    
    wsDash.Range("D5").Value = "Последняя дата"
    wsDash.Range("E5").Formula = "=MAX('Сводка по дням'!A:A)"
    wsDash.Range("E5").NumberFormat = "dd.mm.yyyy"
    
    lastSummaryRow = LastUsedRow(wsSummary)
    lastReasonsRow = LastUsedRow(wsReasons)
    lastFilesRow = LastUsedRow(wsFiles)
    
    DeleteAllCharts wsDash
    
    If lastSummaryRow >= 2 Then
        Set ch = wsDash.ChartObjects.Add(Left:=20, Top:=110, Width:=420, Height:=220)
        With ch.Chart
            .ChartType = xlColumnClustered
            .SetSourceData Source:=wsSummary.Range("A1:C" & lastSummaryRow)
            .HasTitle = True
            .ChartTitle.Text = "Ремонты по дням"
            .Axes(xlCategory).TickLabels.NumberFormat = "dd.mm"
        End With
        
        Set ch = wsDash.ChartObjects.Add(Left:=460, Top:=110, Width:=420, Height:=220)
        With ch.Chart
            .ChartType = xlLine
            .SetSourceData Source:=wsSummary.Range("A1:D" & lastSummaryRow)
            .HasTitle = True
            .ChartTitle.Text = "Выработка по дням"
            .Axes(xlCategory).TickLabels.NumberFormat = "dd.mm"
        End With
        
        Set ch = wsDash.ChartObjects.Add(Left:=20, Top:=350, Width:=420, Height:=220)
        With ch.Chart
            .ChartType = xlLine
            .SetSourceData Source:=wsSummary.Range("A1:E" & lastSummaryRow)
            .HasTitle = True
            .ChartTitle.Text = "Расход топлива по дням"
            .Axes(xlCategory).TickLabels.NumberFormat = "dd.mm"
        End With
        
        Set ch = wsDash.ChartObjects.Add(Left:=460, Top:=350, Width:=420, Height:=220)
        With ch.Chart
            .ChartType = xlColumnClustered
            .SetSourceData Source:=wsSummary.Range("F1:H" & lastSummaryRow)
            .HasTitle = True
            .ChartTitle.Text = "Состояние ДГУ"
        End With
    End If
    
    If lastReasonsRow >= 2 Then
        Set ch = wsDash.ChartObjects.Add(Left:=20, Top:=590, Width:=860, Height:=250)
        With ch.Chart
            .ChartType = xlBarClustered
            .SetSourceData Source:=wsReasons.Range("A1:B" & WorksheetFunction.Min(lastReasonsRow, 11))
            .HasTitle = True
            .ChartTitle.Text = "Топ причин ремонтов"
        End With
    End If
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 FormatSheets(ByVal wsSummary As Worksheet, ByVal wsRepairs As Worksheet, ByVal wsReasons As Worksheet, ByVal wsFiles As Worksheet, ByVal wsDash As Worksheet)
    Dim ws As Worksheet
    For Each ws In Array(wsSummary, wsRepairs, wsReasons, wsFiles)
        With ws.Rows(1)
            .Font.Bold = True
            .Interior.Color = RGB(217, 225, 242)
        End With
        ws.Cells.EntireColumn.AutoFit
        ws.Rows(1).AutoFilter
    Next ws
    
    wsSummary.Columns("A").NumberFormat = "dd.mm.yyyy"
    wsRepairs.Columns("A").NumberFormat = "dd.mm.yyyy"
    wsFiles.Columns("B").NumberFormat = "dd.mm.yyyy"
    
    wsDash.Columns("A:F").ColumnWidth = 16
    wsDash.Range("A3:E5").Font.Bold = True
End Sub

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 Function GetOrCreateSheet(ByVal sheetName As String) As Worksheet
    On Error Resume Next
    Set GetOrCreateSheet = ThisWorkbook.Worksheets(sheetName)
    On Error GoTo 0
    
    If GetOrCreateSheet Is Nothing Then
        Set GetOrCreateSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        GetOrCreateSheet.Name = sheetName
    End If
End Function

Private Function ExtractDateFromFilename(ByVal fileName As String) As Variant
    Dim re As Object, m As Object
    Dim s As String, 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))
        On Error Resume Next
        ExtractDateFromFilename = DateSerial(y, mn, d)
        If Err.Number <> 0 Then ExtractDateFromFilename = Empty
        On Error GoTo 0
    Else
        ExtractDateFromFilename = Empty
    End If
End Function

Private Function FindHeaderRow(ByVal ws As Worksheet, ByVal keywords As Variant) As Long
    Dim r As Long, c As Long, lastCol As Long, txt As String, k As Variant
    Dim score As Long, bestScore As Long, bestRow As Long
    
    bestScore = 0
    bestRow = 0
    
    For r = 1 To WorksheetFunction.Min(10, ws.UsedRange.Rows.Count)
        lastCol = LastUsedColInRow(ws, r)
        score = 0
        For c = 1 To lastCol
            txt = LCase(Trim(CStr(ws.Cells(r, c).Value)))
            If txt <> "" Then
                For Each k In keywords
                    If InStr(txt, LCase(CStr(k))) > 0 Then
                        score = score + 1
                        Exit For
                    End If
                Next k
            End If
        Next c
        If score > bestScore Then
            bestScore = score
            bestRow = r
        End If
    Next r
    
    FindHeaderRow = bestRow
End Function

Private Function FindColumnByKeywords(ByVal ws As Worksheet, ByVal headerRow As Long, ByVal keywords As Variant) As Long
    Dim c As Long, lastCol As Long, txt As String, k As Variant
    
    lastCol = LastUsedColInRow(ws, headerRow)
    For c = 1 To lastCol
        txt = LCase(Trim(CStr(ws.Cells(headerRow, c).Value)))
        If txt <> "" Then
            For Each k In keywords
                If InStr(txt, LCase(CStr(k))) > 0 Then
                    FindColumnByKeywords = c
                    Exit Function
                End If
            Next k
        End If
    Next c
End Function

Private Function LastUsedRow(ByVal ws As Worksheet) As Long
    On Error Resume Next
    LastUsedRow = ws.Cells.Find(What:="*", After:=ws.Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    If LastUsedRow = 0 Then LastUsedRow = 1
    On Error GoTo 0
End Function

Private Function LastUsedColInRow(ByVal ws As Worksheet, ByVal rowNum As Long) As Long
    On Error Resume Next
    LastUsedColInRow = ws.Cells(rowNum, ws.Columns.Count).End(xlToLeft).Column
    If LastUsedColInRow = 0 Then LastUsedColInRow = 1
    On Error GoTo 0
End Function

Private Sub SortStringDates(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

Public Sub CreateRefreshButton()
    Dim ws As Worksheet
    Dim shp As Shape
    
    Set ws = GetOrCreateSheet("Дашборд")
    
    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 = "RefreshMonthData"
End Sub