Создать цикл поиска

Question

У меня есть данные строки, выгруженные на лист с именем "PDFtoEXCEL", и внутри этих данных у меня есть таблицы, которые я хочу извлечь на свой лист с именем "CCE_Lab"

Чтобы найти таблицы, я выполняю поиск по ключевому словуэто доступно только в тех таблицах, которые я ищу, я ищу "Compressibility2"

Затем я смещаюсь от активной ячейки, которая была автоматически выбрана поиском, чтобы скопировать таблицу и ее заголовок из листа "PDFtoEXCEL"на лист "CCE_Lab" После вставки я смещаю одну строку ниже вставленной таблицы

После того, как мне понадобится помощь, я хочу, чтобы макрос искал следующую таблицу с ключевым словом "Compressibility2" ивставьте его из листа "PDFtoEXCEL" в лист "CCE_Lab" на одну строку ниже первой вставки.Я хочу, чтобы этот цикл поиска продолжался до тех пор, пока все мои таблицы на листе "PDFtoEXCEL" не будут скопированы и вставлены на лист "CCE_Lab"

Это код, который у меня есть в настоящее время, в поисках вашей помощи, чтобы завершитьэто:

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

Если ваши «таблицы» не являются таблицами Excel, то, очевидно, вы не сможете решить эту проблему, просто зациклившись на ListObjects.

Так что вместо этого попробуйте цикл Do-Until и выполните цикл по всем Find результатов до тех пор, пока вы не вернетесь к своему первому результату (в конечном итоге он должен вернуться к первому результату).

Что-то вроде:

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

Может быть, что-то вроде приведенного ниже будет делать то, что вам нужно.

Короче говоря, мы перебираем каждый лист table на "PDFtoExcel", проверяем, содержит ли он подстроку, а затем обрабатываемскопировать-вставить оттуда.

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