如果表头有特定字，则需要复制数据

Question

我正在处理多个工作表，其中工作表包含三列的多个数据表，并希望从每个工作表中复制名称。

每个工作表中的数据都不恒定，因为“名称”将位于单元格（B6），（F6），（B15）或（F17）中

每个工作表中的数据在不同的范围内，例如在工作表2中

  

B6：D11
    F7：H12
    B15：D25
    F18：H24

在工作表3上，它的范围将不同。

需要从每个表中复制Name并将其粘贴到sheet1

Private Sub Search_n_Copy()
Dim ws As Worksheet

Dim rngCopy As Range, aCell As Range, bcell As Range
Dim strSearch As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.CutCopyMode = False

strSearch = "Name"

For Each ws In Worksheets
With ws
Set rngCopy = Nothing
    Set aCell = .Columns(2).Find(What:=strSearch, LookIn:=xlValues, _
    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)

    If Not aCell Is Nothing Then
        Set bcell = aCell

        If rngCopy Is Nothing Then
            Set rngCopy = .Rows((aCell.Row + 1) & ":" & (aCell.End(xlDown).Row))
        Else
            Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) & ":" & (aCell.End(xlDown).Row)))
        End If

        Do
            Set aCell = .Columns(2).FindNext(After:=aCell)

            If Not aCell Is Nothing Then
                If aCell.Address = bcell.Address Then Exit Do

                If rngCopy Is Nothing Then
                    Set rngCopy = .Rows((aCell.Row + 1) & (aCell.End(xlDown).Row))
                Else
                    Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) & ":" & (aCell.End(xlDown).Row)))
                End If
            Else
                Exit Do
            End If
        Loop

    End If

    '~~> I am pasting to sheet1. Change as applicable
If Not rngCopy Is Nothing Then rngCopy.Copy Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1)
Range("B2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, -1).Range("A1").Select
ActiveCell.FormulaR1C1 = "x"
Range("A1").Select

End With

我想要做的是复制数据标题为“ Name”的数据，并将其粘贴到工作表中所有可用表的工作表1中，并希望对所有工作表重复该数据并将其粘贴到工作表1中” A1”

Answer 1

如果它们是ListObject中的真正表，则无需搜索单词。您可以遍历对象并通过执行以下操作选择第一列标题...

x=1
For Each ws in ThisWorkbook.Worksheets
    For each tbl In ws.ListObjects
         Sheets("Sheet1").Cells(x,1)=tbl.HeaderRowRange(1)
         x=x + 1
    Next tbl
Next ws

您可以修改特定的位置以适合您的代码，但这效率更高。

Answer 2

如果有人可以帮助解决代码，那将是非常有用的帮助。