Copying an array of dynamic ranges, starting from searched cell value - excel

Question

I have a large sheet of data:
Updated Data
where i need to copy only a speacific part of this data to another worksheet:
The data i need to copy is always 4 cells wide however can be at any row and column. The first column cell at the top will allways be the same text value and i need to copy then from that found cell, 4 cells across to the right and then down to the cells are empty. All subsequent ranges after the first will use the same columns have several empty cells bother above and below each range needed. The macro will be run using a "button" so doesn't need to be checking the value of the cell all the time. The images are simplified versions of the data but are very accurate. 0 is used to show data surrounding range, HELLO is the data inside the range and INT_EXT_DOOR is my searched for cell value which can be in any column between data sets but will be the same inside each data set. The first range always starts at row 2.
Each range has to be numbered, defined by another worksheets cell value. For example, if my cell value is 1 i need it to copy range 1, if my value is 2 copy range 2 ect.
I have been trying to no luck to get anything that works like needed and would appreciate any help, thanks.

Answer 1

Test the next function, please:
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
The above function should be called like this:
Sub testRetBlock()
testReturnBlock "INT_EXT_DOOR", 2
End Sub
But in order to see that the correct range has been returned, you must adapt them in a way (in your test sheet), do differentiate. I mean the second one to contain "HELLO1" (at least on its first row), the following "HELLO2" and so on...

Answer 2

Try this routine if it does what you need. otherwise it should be a good start for adding whatever you need on top.
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
Let me know if you need more help