Как только значение активной ячейки найдено, как выбрать 5 строк выше и 20 строк ниже

Question

Мне помогли с другими проблемами, но это новая проблема, когда ячейка имеет значение данных 4, мне нужно выбрать 5 строк выше этого и 20 строк ниже этого и вырезать / скопировать эти данные на другой лист,У меня все остальное отсортировано, только этот разрез выше и ниже точки данных.

Answer 1

Небольшая демонстрация:

Option Explicit
Const NEGOFFSET = 5
Const POSOFFSET = 20
Sub test()
    Dim r As Range

    Set r = Range("a6") 'Assuming A6 is the target cell
    r.Select 'Just to show the selected range this far
    Set r = r.Offset(-NEGOFFSET, 0).Resize(NEGOFFSET + 1, 1)
    r.Select 'Just to show the selected range this far
    Set r = r.Resize(POSOFFSET + NEGOFFSET + r.Row, 1)
    r.Select 'Just to show the selected range
    '*
    '* Here r holds the wanted range. Handle it
    '*
End Sub

Answer 2

Копировать строки

Sub RowsCopy()

    Const cSource As Variant = "Sheet1" ' Source Worksheet Name/Index
    Const cTarget As Variant = "Sheet2" ' Target Worksheet Name/Index
    Const cRange As String = "A7"       ' Source Cell Range Address
    Const cCrit As Long = 4             ' Criteria
    Const cRowsA As Long = 5            ' Source Rows Above
    Const cRowsB As Long = 20           ' Source Rows Below

    Dim ws As Worksheet   ' Target Worksheet
    Dim FER As Long       ' Target First Empty Row

    ' In Source Cell Range
    With ThisWorkbook.Worksheets(cSource).Range(cRange)
        ' Create a reference to Target Worksheet.
        Set ws = .Parent.Parent.Worksheets(cTarget)
        ' Calculate Target First Empty Row using column 1 (A).
        FER = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1
        ' Check if value in Source Cell Range meets (is equal to) Criteria.
        If .Value = cCrit Then
            ' Calculate Target Range Above.
            ' Calculate Source Range Above.
            ' Copy values of Source Range Above to Target Range Above.
            ws.Rows(FER).Resize(cRowsA).Value _
                    = .Worksheet.Rows(.Row - cRowsA).Resize(cRowsA).Value
            ' Calculate new Target First Empty Row by adding Source Rows Above.
            FER = FER + cRowsA
            ' Calculate Target Range Below.
            ' Calculate Source Range Below.
            ' Copy values of Source Range Below to Target Range Below.
            ws.Rows(FER).Resize(cRowsB).Value _
                    = .Worksheet.Rows(.Row + 1).Resize(cRowsB).Value
        End If
    End With

End Sub

Лист1

Лист2

Копирование и удаление строк

Sub RowsCopyDelete()

    Const cSource As Variant = "Sheet1" ' Source Worksheet Name/Index
    Const cTarget As Variant = "Sheet2" ' Target Worksheet Name/Index
    Const cRange As String = "A7"       ' Source Cell Range Address
    Const cCrit As Long = 4             ' Criteria
    Const cRowsA As Long = 5            ' Source Rows Above
    Const cRowsB As Long = 20           ' Source Rows Below

    Dim ws As Worksheet   ' Target Worksheet
    Dim rng As Range      ' Delete Range
    Dim FER As Long       ' Target First Empty Row

    ' In Source Cell Range
    With ThisWorkbook.Worksheets(cSource).Range(cRange)
        ' Create a reference to Target Worksheet.
        Set ws = .Parent.Parent.Worksheets(cTarget)
        ' Calculate Target First Empty Row using column 1 (A).
        FER = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1
        ' Check if value in Source Cell Range meets (is equal to) Criteria.
        If .Value = cCrit Then
            ' Calculate Target Range Above.
            ' Calculate Source Range Above.
            ' Create a reference to Target Range Above (Delete Range).
            Set rng = .Worksheet.Rows(.Row - cRowsA).Resize(cRowsA)
            ' Copy values of Source Range Above to Target Range.
            ws.Rows(FER).Resize(cRowsA).Value = rng.Value
            ' Calculate new Target First Empty Row by adding Source Rows Above.
            FER = FER + cRowsA
            ' Calculate Target Range Below.
            ' Calculate Source Range Below.
            ' Add Target Range Below to Delete Range.
            Set rng = Union(rng, .Worksheet.Rows(.Row + 1).Resize(cRowsB))
            ' Copy values of Source Range Below to Target Range Below.
            ws.Rows(FER).Resize(cRowsB).Value _
                    = .Worksheet.Rows(.Row + 1).Resize(cRowsB).Value
            ' Delete Source Rows
            rng.Rows.Delete ' .Hidden = True, .ClearContents, .Clear
        End If
    End With

End Sub