Create a looping search

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

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

Answer 2

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