''==================================================================
''удалить даты более познее заданного количества дней
''
'Sub test_FnDelDateMonth()
' FnDelDateMonth activeSheet, 4, 14
'End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function FnDelDateMonth(ByVal oSh As Worksheet, _
ByVal iNbCln As Long, _
ByVal iDateDelta)
Dim iNbRowStart As Long: iNbRowStart = 2
Dim iNbRowEnd As Long
Dim aTemp(), i As Long
Dim dValue As Date
Dim dDateMin As Date: dDateMin = Format(Now - iDateDelta, "DD.MM.YYYY")
With oSh
iNbRowEnd = .Cells(Rows.Count, 1).End(xlUp).Row
aTemp = Range(.Cells(iNbRowStart, iNbCln), .Cells(iNbRowEnd, iNbCln)).value
For i = UBound(aTemp) To LBound(aTemp) Step -1
dValue = aTemp(i, 1)
If dValue < dDateMin Then .Rows(i + 1).Delete
Next i
End With
End Function
'==================================================================
''==================================================================
''удалить даты более познее заданного количества дней
''
Sub test_FnDelDateMonth()
activeSheet.Copy
FnDelDateMonth2 activeSheet, 4, 14
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function FnDelDateMonth2(ByVal oSh As Worksheet, _
ByVal iNbCln As Long, _
ByVal iDateDelta)
Dim iNbRowStart As Long: iNbRowStart = 2
Dim iNbRowEnd As Long
Dim iNbClnEnd As Long
Dim dValue As Date
Dim dDateMin As Date: dDateMin = Format(Now - iDateDelta, "DD.MM.YYYY")
Dim a(), i As Long
On Error Resume Next
With oSh
' iNbCln = Workbooks(Fname1).Sheets(LName).Rows(1).Find(What:="Дата", LookIn:=xlValues, SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
i = .Cells(Rows.Count, 1).End(xlUp).Row
a = Range(.Cells(1, iNbCln), .Cells(i, iNbCln)).value
ReDim B(1 To i, 1 To 1)
'анализ=======================
Do While i > 1
dValue = a(i, 1)
If dValue < dDateMin Then B(i, 1) = 1
i = i - 1
Loop
Erase a
'удаление====================
Dim x As Range
iNbClnEnd = .Cells(1, 256).End(xlToLeft).Column + 2
.Rows.Hidden = False 'на всякий случай, чтоб никто не спрятался
.Cells(1, iNbClnEnd).Resize(UBound(B)) = B
Erase B
'Открыть группировку
.Columns.Hidden = False
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2
Set x = Range(.Cells(1, iNbClnEnd), .Cells(Rows.Count, iNbClnEnd)).Find(1, , , xlWhole)
If Not x Is Nothing Then
Range(.Cells(1, iNbClnEnd), .Cells(Rows.Count, iNbClnEnd)).ColumnDifferences(x).EntireRow.Hidden = True
.UsedRange.SpecialCells(xlCellTypeVisible).EntireRow.Delete
.Rows.Hidden = False
End If
'Закрыть группировку
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
End With
End Function
'==================================================================
'******************************************************************************************************************************
'удаление дат по словарю
Sub Del_DATE()
On Error Resume Next
NbCol = Workbooks(Fname1).Sheets(LName).Rows(1).Find(What:="Дата", LookIn:=xlValues, SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
Dim a(), i As Long ', strS As String
i = Workbooks(Fname1).Sheets(LName).Cells(Rows.Count, 1).End(xlUp).Row
a = Range(Workbooks(Fname1).Sheets(LName).Cells(1, NbCol), Workbooks(Fname1).Sheets(LName).Cells(i, NbCol)).value
ReDim B(1 To i, 1 To 1)
'анализ=======================
Do While i > 1
If dMain.exists(a(i, 1)) Then B(i, 1) = 1
i = i - 1
Loop
Set dMain = Nothing
Erase a
'удаление====================
Dim x As Range
NbCol = Workbooks(Fname1).Sheets(LName).Cells(1, Columns.Count).End(xlToLeft).Column + 2
Workbooks(Fname1).Sheets(LName).Rows.Hidden = False 'на всякий случай, чтоб никто не спрятался
Workbooks(Fname1).Sheets(LName).Cells(1, NbCol).Resize(UBound(B)) = B
Erase B
'Открыть группировку
Workbooks(Fname1).Sheets(LName).Columns.Hidden = False
Workbooks(Fname1).Sheets(LName).Outline.ShowLevels RowLevels:=0, ColumnLevels:=2
Set x = Range(Workbooks(Fname1).Sheets(LName).Cells(1, NbCol), Workbooks(Fname1).Sheets(LName).Cells(Rows.Count, NbCol)).Find(1, , , xlWhole)
If Not x Is Nothing Then
Range(Workbooks(Fname1).Sheets(LName).Cells(1, NbCol), Workbooks(Fname1).Sheets(LName).Cells(Rows.Count, NbCol)).ColumnDifferences(x).EntireRow.Hidden = True
Workbooks(Fname1).Sheets(LName).UsedRange.SpecialCells(xlCellTypeVisible).EntireRow.Delete
Workbooks(Fname1).Sheets(LName).Rows.Hidden = False
End If
'Закрыть группировку
Workbooks(Fname1).Sheets(LName).Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
End Sub
