Sub Delete_Max_Date_in_Sh()

' 'удаляем "пустые" столбцы

'oSh.Rows("1:1").SpecialCells(xlCellTypeConstants, 1).EntireColumn.Delete

' Range("Each_Zone") = Cells(Selection.Row, 14).Value

Const CONST_strSh_EachName As String = "Лист1"

Dim oSh As Worksheet

Call EventsChange(False)

Set oSh = ThisWorkbook.Sheets(CONST_strSh_EachName)

Lng_RowEnd = oSh.Columns(1).Rows(1048576).End(xlUp).row

Dim i As Long

Dim iCh As Long

Dim dDateMax As Date

ar_Date = fun_Array_in_Sh(oSh:=ThisWorkbook.Sheets(CONST_strSh_EachName), Lng_RowStart:=2, Lng_ClnStart:=3, Lng_ClnFindRowEnd:=1, Lng_ClnEnd:=3)

'поиск максимальной даты

dDateMax = CDate(ar_Date(1, 1))

For i = UBound(ar_Date) To LBound(ar_Date) Step -1

If CDate(ar_Date(i, 1)) > dDateMax Then dDateMax = CDate(ar_Date(i, 1))

Next i

Select Case MsgBox("Максимальная дата <" & Format(dDateMax, "DD.MM.YYYY") & ">" & vbCrLf & "" & vbCrLf & "Удалить?", 36, "Удаление последней даты")

Case 6 ' Да

Call Delete_Rows(oSh:=oSh, int_Cln_Del:=3, vVal:=dDateMax) 'oSh.Cells(1, 9).Value)

Lng_RowEnd = oSh.Columns(1).Rows(1048576).End(xlUp).row

ThisWorkbook.Activate

oSh.Select

oSh.Cells(Lng_RowEnd + 1, 1).Select

' ActiveCell.Offset(-1, 0).Range("A1").Select

Application.Goto Reference:=oSh.Range(.Cells(Lng_RowEnd, 1).Address), Scroll:=True

Case 7 ' Нет

End Select

Call EventsChange(True)

End Sub

Sub Delete_Rows(ByVal oSh As Worksheet, _

ByVal int_Cln_Del As Integer, _

ByVal vVal As Variant)

On Error Resume Next

' int_ClnEnd = .Rows(1).Find(What:="Дата", LookIn:=xlValues, SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column

Dim a(), i As Long ', strS As String

With oSh 'массив значений для проверки

i = .Cells(Rows.count, 1).End(xlUp).row

a = Range(.Cells(1, int_Cln_Del), .Cells(i, int_Cln_Del)).Value

ReDim B(1 To i, 1 To 1) 'массив для флага

Do While i > 1 'анализ=======================

If a(i, 1) = vVal Then B(i, 1) = 1

i = i - 1

Loop

Erase a

'удаление====================

.Rows.Hidden = False 'на всякий случай, чтоб никто не спрятался

.Columns.Hidden = False

.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2

Dim x As Range

int_ClnEnd = .Cells(1, Columns.count).End(xlToLeft).Column + 2

.Cells(1, int_ClnEnd).Resize(UBound(B)) = B

Erase B

Set x = Range(.Cells(1, int_ClnEnd), .Cells(Rows.count, int_ClnEnd)).Find(1, , , xlWhole)

If Not x Is Nothing Then

Range(.Cells(1, int_ClnEnd), .Cells(Rows.count, int_ClnEnd)).ColumnDifferences(x).EntireRow.Hidden = True

.UsedRange.SpecialCells(xlCellTypeVisible).EntireRow.Delete

.Rows.Hidden = False

End If

'Закрыть группировку

.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1

End With

End Sub