title: Need to Copy data if header of table have Specific word
body: <p>I am working with multiple sheet where sheet contain multiple data table of three column and wanted to copy Name from each sheet.</p>
  
  <p><a href="https://i.stack.imgur.com/TbIxp.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/TbIxp.png" alt="Check Image Attached"></a></p>
  
  <p>The Data is not constant in each sheet as "name" will be in Cell (B6), (F6), (B15) or (F17)</p>
  
  <p>Data is in different range in each sheet for eg.in Sheet 2 </p>
  
  <blockquote>
    <p>B6:D11<br>
      F7:H12<br>
      B15:D25<br>
      F18:H24  </p>
  </blockquote>
  
  <p>On Sheet 3 it will be in different range.</p>
  
  <p>Need to copy Name from each table and paste it into sheet1</p>
  
  <pre><code>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) &amp; ":" &amp; (aCell.End(xlDown).Row))
          Else
              Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) &amp; ":" &amp; (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) &amp; (aCell.End(xlDown).Row))
                  Else
                      Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) &amp; ":" &amp; (aCell.End(xlDown).Row)))
                  End If
              Else
                  Exit Do
              End If
          Loop
  
      End If
  
      '~~&gt; I am pasting to sheet1. Change as applicable
  If Not rngCopy Is Nothing Then rngCopy.Copy Sheets("Sheet1").Range("A" &amp; 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
  </code></pre>
  
  <p>What I want to do is need to copy data which has Data header as "Name" and past it into Sheet 1 for all the table available in sheet and want to repeat it for all the sheet and paste it in Sheet 1 "A1"</p>