Отбор строк по заданным параметрам в массив

Question

Коллеги! Вылетает код (out of range) при выводе строк из массива в новый лист (я вообще даже не уверен, что с формированием массива всё в порядке):

Sub BKFindDeviations()

Dim Deviations() As Variant
Dim rng As Range
Dim Mnth1 As Date
Dim Mnth2 As Date
Dim MnthRowCounter As Long
Dim LoopCounter As Long
Dim r As Range
Dim k As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Mnth1 = "01.01.2020" 'Mnth1 = InputBox("Ââåäèòå ïåðâîå ÷èñëî ìåñÿöà, êîòîðûé áóäåò ñðàâíèâàòüñÿ ñ ïðîøëûìè ìåñÿöàì (ôîðìàò: dd.mm.yyyy")
Mnth2 = "01.02.2020" 'Mnth2 = InputBox("Ââåäèòå ïåðâîå ÷èñëî ìåñÿöà, êîòîðûé áóäåò ÿâëÿòüñÿ áàçîé äëÿ ñðàâíåíèÿ (ôîðìàò: dd.mm.yyyy")

For Each r In Range("a1", Range("a1").End(xlDown))
    If r.Offset(0, 8).Value = Mnth1 Or r.Offset(0, 8).Value = Mnth2 Then
        MnthRowCounter = MnthRowCounter + 1
        ReDim Preserve Deviations(1 To 17, 1 To MnthRowCounter)
        For LoopCounter = 1 To 17 'Range("a1", Range("a1").End(xlToRight))
            Deviations(LoopCounter, MnthRowCounter) = r.Offset(0, LoopCounter - 1).Value
        Next LoopCounter
    End If
Next r

'Deviations = Range("a1", Range("a1").End(xlToRight).End(xlDown))

Worksheets.Add

Range(ActiveCell, ActiveCell.Offset(UBound(Deviations, 1) - 1, UBound(Deviations, 2) - 1)).Value = Deviations

Erase Deviations

Set rng = Range("a1", Range("a1").End(xlDown).End(xlToRight))

'×èñòèì ôîðìàò
With rng
    .ClearFormats
End With

'Óñòàíàâëèâàåì ôîðìàò "Äàòà" â ñòîëáöå Äàò
For k = 1 To Cells(Rows.Count, 9).End(xlUp).Row
    'If Cells(r, 9) Like "##.##.####" Then
        'Cells(r, 9) = DateSerial(Right(Cells(r, 9), 4), Mid(Cells(r, 9), 4, 2), Left(Cells(r, 9), 2))
        Cells(k, 9).NumberFormat = "dd.mm.yyyy;@"
    'End If
Next k

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic End Sub

Значения задействованных в операторе переменных перед "вылетом":

Обновил код

Answer 1

Я бы всё-таки рекомендовал переключиться на использование автофильтра прямо сейчас - получится и короче, и проще, и - я так думаю - надёжнее

Sub BKFindDeviations()
Dim Mnth1 As String, Mnth2 As String
Dim aRng As Range, aDest As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Mnth1 = "01.01.2020" ' Или с помощью InputBox()
Mnth2 = "01.02.2020"
    Set aRng = Range("A1").CurrentRegion
    Worksheets.Add After:=Worksheets(Worksheets.Count)
    Set aDest = Worksheets(Worksheets.Count).Range("A1")
    aRng.AutoFilter
    aRng.AutoFilter Field:=10, Criteria1:="=" & Mnth1, Operator:=xlOr, Criteria2:="=" & Mnth2
    aRng.SpecialCells(xlCellTypeVisible).Copy Destination:=aDest
    Application.CutCopyMode = False
    aRng.AutoFilter
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Разумеется, можно перебрать и каждую из строк по одной, отбирая нужные для последующего копирования. Это можно сделать, например, так:

Sub BKFindDeviations()
    Dim aRows() As Long
    Dim srcSheet As Worksheet
    Dim src As Range
    Dim aCell As Range
    Dim Mnth1 As Date
    Dim Mnth2 As Date
    Dim MnthRowCounter As Long
    Dim LoopCounter As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Mnth1 = "01.01.2020"
    Mnth2 = "01.02.2020"
    Set srcSheet = ActiveSheet
    Set src = srcSheet.Range("A1").CurrentRegion
    For Each aCell In Intersect(srcSheet.Columns(9), src).Cells
        If aCell.Value = Mnth1 Or aCell.Value = Mnth2 Then
            MnthRowCounter = MnthRowCounter + 1
            ReDim Preserve aRows(1 To MnthRowCounter)
            aRows(MnthRowCounter) = aCell.Row
        End If
    Next aCell
    
    Worksheets.Add
    Set aCell = ActiveSheet.Range("A1")
    src.Rows(1).Copy Destination:=aCell ' Строка заголовков
    Set aCell = aCell.Offset(1, 0)
    For LoopCounter = LBound(aRows) To UBound(aRows)
        src.Rows(aRows(LoopCounter)).Copy Destination:=aCell
        Set aCell = aCell.Offset(1, 0)
    Next LoopCounter
    Erase aRows
    Columns.AutoFit
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

БЛОГ НА HUSL

Отбор строк по заданным параметрам в массив

Ответы (1 шт):