Create a looping search - excel

Question

I have row data dumped in sheet named "PDFtoEXCEL" and inside this data I have tables that I want to extract into my sheet named "CCE_Lab"
To find the tables I do a search for a keyword that is only available in those tables I am looking for, I search for "Compressibility2"
Then i offset from the active cell which was automatically selected by the search to copy the table and its title from sheet "PDFtoEXCEL" to sheet "CCE_Lab"
After the paste I offset one row below the pasted table
After that is where I need the help, I want the macro to search for the next table with keyword "Compressibility2" and paste it from sheet "PDFtoEXCEL" to sheet "CCE_Lab" one line below the first paste.
I want this search loop to keep going on until all my tables in sheet "PDFtoEXCEL" are copied and pasted to sheet "CCE_Lab"
This is the code I currently have, looking for your help to complete it:
Sub CCE_Tables_Group()
'
' CCE_Tables_Group Macro
' grouping CCE tables from PDF input
'
'
Sheets("PDFtoEXCEL").Select
ActiveCell.Offset(-2546, 0).Range("A1").Select
Cells.Find(What:="Compressibility2", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(-2, -4).Range("A1:F25").Select
Selection.Copy
Sheets("CCE_Lab").Select
ActiveCell.Select
ActiveSheet.Paste
ActiveCell.Offset(26, 0).Range("A1").Select
End Sub

Answer 1

If your "tables" aren't Excel tables, then obviously you can't solve this by conveniently looping over ListObjects.
So instead try a Do-Until loop, and loop through all Find results until you're back at your first one (it should loop back to your first result eventually).
Something like:
Option Explicit
Private Sub CopyMatchingTablesToSheet()
Const NUMBER_OF_ROWS_BETWEEN_PASTES As Long = 1
With ThisWorkbook
Dim outputSheet As Worksheet
Set outputSheet = .Worksheets("CCE_Lab")
'outputSheet.Cells.Clear ' Uncomment this if you want to clear the sheet before pasting.
Dim sourceSheet As Worksheet
Set sourceSheet = .Worksheets("PDFtoExcel")
End With
Dim findResult As Range
Set findResult = sourceSheet.Cells.Find(What:="Compressibility2", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If findResult Is Nothing Then
MsgBox ("Could not find a single 'Compressibility2' in worksheet '" & sourceSheet.Name & "'." & vbNewLine & vbNewLine & "Code will stop running now.")
Exit Sub
End If
Dim lastRow As Long
lastRow = outputSheet.Cells(outputSheet.Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then lastRow = lastRow + 1 + NUMBER_OF_ROWS_BETWEEN_PASTES
Dim firstAddressFound As String
firstAddressFound = findResult.Address
Dim addressFound As String
Do
With findResult.Offset(-2, -4).Range("A1:F25") 'Magic numbers used in offset.
.Copy
outputSheet.Cells(lastRow, "A").PasteSpecial xlPasteValuesAndNumberFormats ' If you want to paste "everything", then use something like xlPasteAll below
lastRow = lastRow + .Rows.Count + NUMBER_OF_ROWS_BETWEEN_PASTES
End With
Set findResult = sourceSheet.Cells.FindNext(findResult)
addressFound = findResult.Address
DoEvents ' Get rid of this if you want.
Loop Until (firstAddressFound = addressFound) Or (findResult Is Nothing) ' This second condition is likely unnecessary
Application.CutCopyMode = False
End Sub

Answer 2

Maybe something like the below will do what you're after.
In short, we loop through every table on "PDFtoExcel" sheet, check if it contains the sub-string and then handle the copy-paste from there.
Option Explicit
Private Sub CopyMatchingTablesToSheet()
With ThisWorkbook
' Uncomment the line below if you want to clear the sheet before pasting.
' .Worksheets("CCE_LAB").Cells.Clear
Const NUMBER_OF_ROWS_BETWEEN_PASTES As Long = 1
Dim table As ListObject
For Each table In .Worksheets("PDFtoExcel").ListObjects
' table.Range (below) will search the table's body and headers for "Compressibility2"
' If you only want to search the table's body, then change to table.DataBodyRange
Dim findResult As Range
Set findResult = table.Range.Find(What:="Compressibility2", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not (findResult Is Nothing) Then
' Again, if you only to copy-paste the table's body,
' then change below to table.DataBodyRange.Copy
table.Range.Copy
With .Worksheets("CCE_LAB")
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then lastRow = lastRow + 1 + NUMBER_OF_ROWS_BETWEEN_PASTES
' If you want to paste "everything", then use something like xlPasteAll below
' But I think xlPasteAll will create another Excel table on your CCE_Lab sheet
' with some new, unique name -- which can make the document a mess.
' Your call.
.Cells(lastRow, "A").PasteSpecial xlPasteValuesAndNumberFormats
End With
End If
Next table
Application.CutCopyMode = False
End With
End Sub