Копирование массива динамических c диапазонов, начиная с найденного значения ячейки

Question

У меня есть большой лист данных:

Обновленные данные

где мне нужно скопировать только c часть этих данных на другой лист:

Данные, которые мне нужно скопировать, всегда имеют ширину 4 ячейки, но могут находиться в любой строке и столбце. Первая ячейка столбца вверху всегда будет иметь одно и то же текстовое значение, и мне нужно скопировать из этой найденной ячейки 4 ячейки вправо, а затем вниз, чтобы ячейки были пустыми. Все последующие диапазоны после первого будут использовать те же столбцы, есть несколько пустых ячеек, над и под каждым необходимым диапазоном. Макрос будет запускаться с помощью «кнопки», поэтому нет необходимости постоянно проверять значение ячейки. Изображения являются упрощенными версиями данных, но очень точны. 0 используется для отображения данных, окружающих диапазон, HELLO - это данные внутри диапазона, а INT_EXT_DOOR - это значение ячейки, которое я искал, которое может находиться в любом столбце между наборами данных, но будет одинаковым внутри каждого набора данных. Первый диапазон всегда начинается со строки 2.

Каждый диапазон должен быть пронумерован, определяемым значением другой ячейки рабочего листа. Например, если значение моей ячейки равно 1, мне нужно скопировать диапазон 1, если мое значение равно 2, скопировать диапазон 2 и т. Д.

Я безуспешно пытался получить что-то, что работает как необходимо, и был бы признателен любая помощь, спасибо.

Answer 1

Попробуйте эту процедуру, если она вам подходит. в противном случае это должно быть хорошим началом для добавления всего, что вам нужно поверх.

Option Explicit

Sub CopyBlock()
    Dim wb As Excel.Workbook
    Dim wsSource As Excel.Worksheet
    Dim wsDest As Excel.Worksheet
    Dim wsSelect As Excel.Worksheet
    Dim lBlockNo As Long
    Dim strCellID As String
    Dim lBlock As Long
    Dim lRow As Long
    Dim lBlockRow As Long
    Dim lBlockCol As Long
    Dim searchRange As Excel.Range
    Dim bRange As Excel.Range
    Dim cRange As Excel.Range

    Set wb = ActiveWorkbook

' set the worksheet objects
    Set wsSource = wb.Sheets("Source")
    Set wsDest = wb.Sheets("Dest")
    Set wsSelect = wb.Sheets("Select")      ' here you select which block you want to copy

' Identifier String
    strCellID = "INT_EXT_DOOR"

' Which block to show. We assume that the number is in cell A1, but could be anywhere else
    lBlockNo = wsSelect.Range("A1")

    lRow = 1

' Find block with lBlockNo
    For lBlock = 1 To lBlockNo

' Search the identifier string in current row
        Do
            lRow = lRow + 1
            Set searchRange = wsSource.Rows(lRow)
            Set bRange = searchRange.Find(strCellID, LookIn:=xlValues)
        Loop While (bRange Is Nothing)

    Next lBlock

    lBlockRow = bRange.Row
    lBlockCol = bRange.Column

' Search the first with empty cell
    Do
        lRow = lRow + 1
    Loop While wsSource.Cells(lRow, lBlockCol) <> ""

' Copy the range found into the destination sheet
    Range(Cells(lBlockRow, lBlockCol), Cells(lRow - 1, lBlockCol + 3)).Copy wsDest.Range("A1")

' Note the block copied
    wsDest.Cells(1, 6) = "Block No:"
    wsDest.Cells(1, 8) = lBlockNo

' Clean up (not absolutely necessary, but good practice)
    Set searchRange = Nothing
    Set bRange = Nothing
    Set cRange = Nothing
    Set wsSource = Nothing
    Set wsDest = Nothing
    Set wsSelect = Nothing
    Set wb = Nothing

End Sub

Дайте мне знать, если вам понадобится дополнительная помощь

Answer 2

Протестируйте следующую функцию, пожалуйста:

Private Function testReturnBlock(strBlock As String, blkNo As Long)
   Dim sh As Worksheet, ws As Worksheet, lastRow As Long, searchC As Range
   Dim rng As Range

    Set sh = ActiveSheet ' use here your sheet to be processed
    Set ws = Worksheets("Return") 'use here your sheet where the data will be returned

    Set searchC = sh.UsedRange.Find(strBlock)
    If searchC Is Nothing Then MsgBox "No such a field in the worksheet...": Exit Function

    lastRow = sh.Cells(Rows.Count, searchC.Column).End(xlUp).row
    'The following part works well only if the blocks are separated by empty rows, as you said it is your sheet data case...
    Set rng = sh.Range(searchC, sh.Cells(LastRow, searchC.Column)).SpecialCells(xlCellTypeConstants)
     ws.Range("A1").Resize(rng.Areas(blkNo).Rows.Count, 4).Value = rng.Areas(blkNo).Resize(, 4).Value
End Function

Вышеупомянутая функция должна вызываться следующим образом:

Sub testRetBlock()
   testReturnBlock "INT_EXT_DOOR", 2
End Sub

Но для того, чтобы убедиться, что был возвращен правильный диапазон, вы должны адаптировать их (в вашем тестовом листе), дифференцировать. Я имею в виду, что второй должен содержать «HELLO1» (по крайней мере, в его первой строке), следующий «HELLO2» и так далее ...