Pastein: 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, wsRepair

Загрузка данных
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
    
    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
                    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
        End If
        fileName = Dir
    Loop
    
    WriteSummary wsSummary, dictSummary
    WriteReasons wsReasons, dictReasons
    BuildDashboard wsDash, wsSummary, wsReasons, wsFiles
    FormatSheets 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 CreateRefreshButton()
    Dim ws As Worksheet
    Dim shp As Shape
    
    Set ws = GetOrCreateSheetSafe("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 = "RefreshMonthData"
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 = GetOrCreateSheetSafe("Dash")
    Set wsSummary = GetOrCreateSheetSafe("Summary")
    Set wsRepairs = GetOrCreateSheetSafe("Repairs")
    Set wsReasons = GetOrCreateSheetSafe("Reasons")
    Set wsFiles = GetOrCreateSheetSafe("Files")
    
    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
    
    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
    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 = 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
    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(Files!A:A)-1)"
    
    wsDash.Range("D3").Value = "Дней с данными"
    wsDash.Range("E3").Formula = "=MAX(0,COUNTA(Summary!A:A)-1)"
    
    wsDash.Range("A4").Value = "Всего ремонтов"
    wsDash.Range("B4").Formula = "=SUM(Summary!C:C)"
    
    wsDash.Range("D4").Value = "Сумма выработки"
    wsDash.Range("E4").Formula = "=SUM(Summary!D:D)"
    
    wsDash.Range("A5").Value = "Расход топлива"
    wsDash.Range("B5").Formula = "=SUM(Summary!E:E)"
    
    wsDash.Range("D5").Value = "Последняя дата"
    wsDash.Range("E5").Formula = "=MAX(Summary!A:A)"
    wsDash.Range("E5").NumberFormat = "dd.mm.yyyy"
    
    lastSummaryRow = LastUsedRow(wsSummary)
    lastReasonsRow = LastUsedRow(wsReasons)
    
    DeleteAllCharts wsDash
    
    If lastSummaryRow >= 2 Then
        Set ch = wsDash.ChartObjects.Add(Left:=20, Top:=110, Width:=420, Height:=220)
        With ch.Chart
            .ChartType = xlColumnClustered
            Do While .SeriesCollection.Count > 0
                .SeriesCollection(1).Delete
            Loop
            .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:=110, Width:=420, Height:=220)
        With ch.Chart
            .ChartType = xlLine
            Do While .SeriesCollection.Count > 0
                .SeriesCollection(1).Delete
            Loop
            .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:=20, Top:=350, Width:=420, Height:=220)
        With ch.Chart
            .ChartType = xlLine
            Do While .SeriesCollection.Count > 0
                .SeriesCollection(1).Delete
            Loop
            .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:=460, Top:=350, Width:=420, Height:=220)
        With ch.Chart
            .ChartType = xlColumnClustered
            Do While .SeriesCollection.Count > 0
                .SeriesCollection(1).Delete
            Loop
            .SeriesCollection.NewSeries
            .SeriesCollection(1).Name = "=""Последняя дата"""
            .SeriesCollection(1).XValues = Array("В работе", "В резерве", "В ремонте")
            .SeriesCollection(1).Values = Array(wsSummary.Cells(lastSummaryRow, 6).Value, wsSummary.Cells(lastSummaryRow, 7).Value, wsSummary.Cells(lastSummaryRow, 8).Value)
            .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
            Do While .SeriesCollection.Count > 0
                .SeriesCollection(1).Delete
            Loop
            .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 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)
    FormatOneSheet wsSummary
    FormatOneSheet wsRepairs
    FormatOneSheet wsReasons
    FormatOneSheet 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:E5").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 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 GetOrCreateSheetSafe(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 GetOrCreateSheetSafe = ws
            Exit Function
        End If
    Next ws
    
    Set ws = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
    
    candidate = CleanSheetName(sheetName)
    If candidate = "" Then candidate = "SheetX"
    
    On Error Resume Next
    ws.Name = candidate
    If Err.Number = 0 Then
        On Error GoTo 0
        Set GetOrCreateSheetSafe = 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 GetOrCreateSheetSafe = ws
End Function

Private Function CleanSheetName(ByVal s As String) As String
    Dim badChars As Variant
    Dim ch As Variant
    
    badChars = Array(":", "\", "/", "?", "*", "[", "]")
    CleanSheetName = Trim$(s)
    
    For Each ch In badChars
        CleanSheetName = Replace(CleanSheetName, CStr(ch), "")
    Next ch
    
    If Len(CleanSheetName) > 31 Then
        CleanSheetName = Left$(CleanSheetName, 31)
    End If
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))
        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
    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
        LastUsedRow = 1
    Else
        LastUsedRow = f.Row
    End If
End Function

Private Function LastUsedColInRow(ByVal ws As Worksheet, ByVal rowNum As Long) As Long
    LastUsedColInRow = ws.Cells(rowNum, ws.Columns.Count).End(xlToLeft).Column
    If LastUsedColInRow < 1 Then LastUsedColInRow = 1
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
Больше возможностей при регистрации:
