title: How can I Copy Data only if Header is "Name"?
body: <p><img src="https://i.stack.imgur.com/aDWI5.png" alt="enter image description here" /></p>
  <p>I have workbook with around 50 sheets in it, some of random sheet have Employee names in it. I want all the name to be copied in sheet 1 (A1)</p>
  <p>Please note that data is not in table format.</p>
  <p>I want Macro to run in all sheet and look out for Name header and paste it in sheet 1 (A1).</p>
  <p>Please note &quot;Name&quot; list can be anywhere in the sheet there are no specific range so macro needs to find &quot;Name&quot; word and copy entire list till next blank row and past it into Sheet 1 again find &quot;Name&quot; word and paste it into sheet 1 below available list.</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 = &quot;Name&quot;
       
      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; &quot;:&quot; &amp; (aCell.End(xlDown).Row))
              Else
                  Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) &amp; &quot;:&quot; &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; &quot;:&quot; &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(&quot;Sheet1&quot;).Range(&quot;A&quot; &amp; Rows.Count).End(xlUp).Offset(1)
          Range(&quot;B2&quot;).Select
          Selection.End(xlDown).Select
          ActiveCell.Offset(0, -1).Range(&quot;A1&quot;).Select
          ActiveCell.FormulaR1C1 = &quot;x&quot;
          Range(&quot;A1&quot;).Select
      
      End With
  </code></pre>