Question

我将行数据转储到名为“ PDFtoEXCEL”的工作表中，并且在此数据中，我有一些表要提取到名为“ CCE_Lab”的工作表中

要查找表，我搜索仅在我要查找的表中可用的关键字，我搜索“ Compressibility2”

然后，i从活动单元格偏移，该单元格是通过搜索自动选择的，以将表及其标题从工作表“ 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

也许像下面这样会做你想要做的。

简而言之，我们遍历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

Answer 2

如果您的“表”不是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

创建循环搜索

2 个答案: