MyTetra Share
Делитесь знаниями!
удалить даты более познее заданного количества дней
16.03.2019
23:43
Текстовые метки: DelDate, Date
Раздел: !Закладки - VBA

''==================================================================

''удалить даты более познее заданного количества дней

''

'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

Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования