Need to Copy Data only if Header is “Name”

Question

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)

Please note that data is not in table format.

I want Macro to run in all sheet and look out for Name header and paste it in sheet 1 (A1).

Please note "Name" list can be anywhere in the sheet there are no specific range so macro needs to find "Name" word and copy entire list till next blank row and past it into Sheet 1 again find "Name" word and paste it into sheet 1 below available list.

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

Post your attempt and maybe we can help. Simply saying "I want a macro" should hopefully get you nowhere on SO. — Dean
You can loop on each sheet and use Range.Find() to search for "Employee Name" — Marcucciboy2
You can search for any cell containing a "NAME" string by using RegEx and this website is super useful for testing your RegEx on the fly. — Tom

Dick Kusleika Dick Kusleika · Accepted Answer · 2019-07-19T13:22:29

You can use the Range.Find method to find all the instances of "name". The key to this is keeping track of the first one that you find so that when Find gets back to that cell you don't keep processing. If you don't do this, it will keep going in a circle forever. Here's an example.

Private Sub Search_n_Copy()

    Dim rFound As Range
    Dim sFirstFound As String

    'find the first instance of name
    Set rFound = Sheet1.UsedRange.Find("name", , xlValues, xlPart)

    'continue only if you found at least one instance
    If Not rFound Is Nothing Then
        'record the first one you found because Find loops back on itself
        sFirstFound = rFound.Address

        Do
            'copy the name to another sheet
            Sheet1.Range(rFound.Offset(1), rFound.Offset(1).End(xlDown)).Copy _
                Sheet2.Range("A1000").End(xlUp).Offset(1)

            'find the next instance of name
            Set rFound = Sheet1.UsedRange.FindNext(rFound)

        'stop looping when you get back to the first found cell
        Loop Until rFound.Address = sFirstFound
    End If

End Sub

If you want to do it for every sheet (and probably not the one where you're writing the results) it would look like this

Sub Search_n_Copy()

    Dim rFound As Range
    Dim sFirstFound As String
    Dim shSrc As Worksheet
    Dim shDest As Worksheet

    'Change this to match your sheet's name
    Set shDest = ThisWorkbook.Worksheets("Results")

    For Each shSrc In Worksheets
        If shSrc.Name <> shDest.Name Then
            With shSrc
                Set rFound = shSrc.UsedRange.Find("Name", , xlValues, xlPart)
                If Not rFound Is Nothing Then
                    sFirstFound = rFound.Address
                    Do
                        shSrc.Range(rFound.Offset(1), rFound.Offset(1).End(xlDown)).Copy _
                            shDest.Range("A1000").End(xlUp).Offset(1)
                        Set rFound = shSrc.UsedRange.FindNext(rFound)
                    Loop Until rFound.Address = sFirstFound
                End If
            End With
        End If
    Next shSrc

End Sub

Need to Copy Data only if Header is “Name”

1 Answers