Pastein: Option Explicit Private Const REPORT_SHEET_DASH As String = "Дашборд" Private Const REPORT_SHEET_SUMMARY As String = "Сводка" Private Const REPORT_SHEET

Загрузка данных
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 = "Файлы"

' Если после вставки VBA заменит русский текст на ?????,
' эти 3 строки вбейте руками в редакторе VBA:
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_RUNNING As Long = 8
Private Const DES_COL_RESERVE As Long = 9
Private Const DES_COL_REPAIR As Long = 10
Private Const DES_COL_LOAD As Long = 11
Private Const DES_COL_OIL As Long = 23
Private Const DES_COL_FUEL As Long = 25
Private Const DES_COL_OUTPUT As Long = 42

Private Const BOILERS_COL_FUEL As Long = 19

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 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")

    ПодготовитьЛисты 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 = ИзвлечьДатуИзИмениФайла(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
    ПостроитьДашборд wsDash, wsSummary, wsReasons, wsFiles
    ОформитьЛисты wsSummary, wsRepairs, wsReasons, wsFiles, wsDash

    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)
    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)

    wsDash.Cells.Clear
    wsSummary.Cells.Clear
    wsRepairs.Cells.Clear
    wsReasons.Cells.Clear
    wsFiles.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("Файл", "Дата", "Статус", "Комментарий")
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, cntWork, cntReserve, cntRepairState)
    desOutput = СчитатьВыработкуДЭС(wb)
    desFuel = СчитатьТопливоДЭС(wb)
    desOil = СчитатьМаслоДЭС(wb)
    boilersFuel = СчитатьТопливоКотельных(wb)
    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, dictReasons, 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, 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 idVal As Variant, nameVal As Variant
    Dim vWork As Variant, vReserve As Variant, vRepair As Variant, vLoad As Variant

    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

    For r = 1 To lastRow
        idVal = ws.Cells(r, 1).Value
        nameVal = ws.Cells(r, 2).Value

        If IsNumeric(idVal) Then
            vWork = ws.Cells(r, DES_COL_RUNNING).Value
            vReserve = ws.Cells(r, DES_COL_RESERVE).Value
            vRepair = ws.Cells(r, DES_COL_REPAIR).Value
            vLoad = ws.Cells(r, DES_COL_LOAD).Value

            If Trim$(CStr(vWork)) = "+" 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

            If IsNumeric(vLoad) Then
                totalLoad = totalLoad + CDbl(vLoad)
            End If
        End If
    Next r

    СчитатьДЭСНагрузкуИСтатусы = totalLoad
End Function

Private Function СчитатьВыработкуДЭС(ByVal wb As Workbook) As Double
    Dim ws As Worksheet
    Dim lastRow As Long, r As Long
    Dim totalOutput As Double
    Dim idVal As Variant, v As Variant

    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

    For r = 1 To lastRow
        idVal = ws.Cells(r, 1).Value
        If IsNumeric(idVal) Then
            v = ws.Cells(r, DES_COL_OUTPUT).Value
            If IsNumeric(v) Then totalOutput = totalOutput + CDbl(v)
        End If
    Next r

    СчитатьВыработкуДЭС = totalOutput
End Function

Private Function СчитатьТопливоДЭС(ByVal wb As Workbook) As Double
    Dim ws As Worksheet
    Dim lastRow As Long, r As Long
    Dim totalFuel As Double
    Dim idVal As Variant, v As Variant

    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

    For r = 1 To lastRow
        idVal = ws.Cells(r, 1).Value
        If IsNumeric(idVal) Then
            v = ws.Cells(r, DES_COL_FUEL).Value
            If IsNumeric(v) Then totalFuel = totalFuel + CDbl(v)
        End If
    Next r

    СчитатьТопливоДЭС = totalFuel
End Function

Private Function СчитатьМаслоДЭС(ByVal wb As Workbook) As Double
    Dim ws As Worksheet
    Dim lastRow As Long, r As Long
    Dim totalOil As Double
    Dim idVal As Variant, v As Variant

    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

    For r = 1 To lastRow
        idVal = ws.Cells(r, 1).Value
        If IsNumeric(idVal) Then
            v = ws.Cells(r, DES_COL_OIL).Value
            If IsNumeric(v) Then totalOil = totalOil + CDbl(v)
        End If
    Next r

    СчитатьМаслоДЭС = totalOil
End Function

Private Function СчитатьТопливоКотельных(ByVal wb As Workbook) As Double
    Dim ws As Worksheet
    Dim lastRow As Long, r As Long
    Dim totalFuel As Double
    Dim v As Variant

    On Error Resume Next
    Set ws = wb.Worksheets(SRC_SHEET_BOILERS)
    On Error GoTo 0
    If ws Is Nothing Then Exit Function

    lastRow = ПоследняяСтрока(ws)
    totalFuel = 0

    For r = 1 To lastRow
        v = ws.Cells(r, BOILERS_COL_FUEL).Value
        If IsNumeric(v) Then totalFuel = totalFuel + CDbl(v)
    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 dictReasons As Object, 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 wsDash As Worksheet, ByVal wsSummary As Worksheet, ByVal wsReasons As Worksheet, ByVal wsFiles As Worksheet)
    Dim lastSummaryRow As Long, lastReasonsRow 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 = ПоследняяСтрока(wsSummary)
    lastReasonsRow = ПоследняяСтрока(wsReasons)

    УдалитьВсеДиаграммы 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("E2:E" & lastSummaryRow)
            .HasTitle = True
            .ChartTitle.Text = "Выработка ДЭС по дням"
        End With

        Set ch = wsDash.ChartObjects.Add(Left:=20, Top:=370, 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("F2:F" & lastSummaryRow)
            .HasTitle = True
            .ChartTitle.Text = "Топливо ДЭС по дням"
        End With

        Set ch = wsDash.ChartObjects.Add(Left:=460, Top:=370, 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("G2:G" & lastSummaryRow)
            .HasTitle = True
            .ChartTitle.Text = "Топливо котельных по дням"
        End With

        Set ch = wsDash.ChartObjects.Add(Left:=20, Top:=610, 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

        Set ch = wsDash.ChartObjects.Add(Left:=460, Top:=610, Width:=420, Height:=220)
        With ch.Chart
            .ChartType = xlColumnClustered
            ОчиститьСерии ch.Chart
            .SeriesCollection.NewSeries
            .SeriesCollection(1).Name = "=""Состояние ДГУ"""
            .SeriesCollection(1).XValues = Array("В работе", "В резерве", "В ремонте")
            .SeriesCollection(1).Values = Array(wsSummary.Cells(lastSummaryRow, 9).Value, wsSummary.Cells(lastSummaryRow, 10).Value, wsSummary.Cells(lastSummaryRow, 11).Value)
            .HasTitle = True
            .ChartTitle.Text = "Состояние ДГУ"
        End With

        Set ch = wsDash.ChartObjects.Add(Left:=20, Top:=850, 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("D2:D" & lastSummaryRow)
            .HasTitle = True
            .ChartTitle.Text = "Нагрузка ДЭС по дням"
        End With

        Set ch = wsDash.ChartObjects.Add(Left:=460, Top:=850, 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("M2:M" & lastSummaryRow)
            .HasTitle = True
            .ChartTitle.Text = "Расход масла ДЭС по дням"
        End With
    End If

    If lastReasonsRow >= 2 Then
        Set ch = wsDash.ChartObjects.Add(Left:=20, Top:=1090, 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 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 ОформитьЛисты(ByVal wsSummary As Worksheet, ByVal wsRepairs As Worksheet, ByVal wsReasons As Worksheet, ByVal wsFiles As Worksheet, ByVal wsDash As Worksheet)
    ОформитьОдинЛист wsSummary
    ОформитьОдинЛист wsRepairs
    ОформитьОдинЛист wsReasons
    ОформитьОдинЛист wsFiles

    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: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
    Dim candidate As String
    Dim i As Long

    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))

    candidate = ОчиститьИмяЛиста(sheetName)
    If candidate = "" Then candidate = "Лист"

    On Error Resume Next
    ws.Name = candidate
    If Err.Number = 0 Then
        On Error GoTo 0
        Set ПолучитьИлиСоздатьЛист = ws
        Exit Function
    End If
    Err.Clear

    For i = 1 To 99
        ws.Name = Left$(candidate, 28) & "_" & CStr(i)
        If Err.Number = 0 Then Exit For
        Err.Clear
    Next i
    On Error GoTo 0

    Set ПолучитьИлиСоздатьЛист = ws
End Function

Private Function ОчиститьИмяЛиста(ByVal s As String) As String
    Dim badChars As Variant
    Dim ch As Variant

    badChars = Array(":", "\", "/", "?", "*", "[", "]")
    ОчиститьИмяЛиста = Trim$(s)

    For Each ch In badChars
        ОчиститьИмяЛиста = Replace(ОчиститьИмяЛиста, CStr(ch), "")
    Next ch

    If Len(ОчиститьИмяЛиста) > 31 Then
        ОчиститьИмяЛиста = Left$(ОчиститьИмяЛиста, 31)
    End If
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))
        On Error Resume Next
        ИзвлечьДатуИзИмениФайла = DateSerial(y, mn, d)
        If Err.Number <> 0 Then ИзвлечьДатуИзИмениФайла = Empty
        On Error GoTo 0
    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 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
Больше возможностей при регистрации:
