Excel VBA code to select cells that contain a certain text string in one workbook, and then copy and paste these cells into a new workbook

Question

I have a large set of data contained within single column in an Excel spreadsheet. I have been trying to work out a way of automating a method to select certain data from this column in one workbook, and paste it into a column in a new workbook.

For example, I have a list of names in the column. I wanted to select any cells that contain the text "First name:", and then copy and paste these cells into a column in a different workbook.

I can do this manually using the 'Find All' tool within Excel, selecting the cells using 'Find what:', and then using Ctrl+A to select all the items found, then closing the 'Find All' tool, and using Ctrl+C to copy all the cells, moving on to the next workbook, and then using Ctrl+V to paste these cells. However, I need to do this process quite a large number of times, and unfortunately the Macro recorder does not record any queries / processes performed in the 'Find All' tool.

I'm assuming that I need some VBA code, but have been unable to find anything suitable on the web / forums.

Answer 1

This is just a sample to get you started:

Sub Luxation()
    Dim K As Long, r As Range, v As Variant
    K = 1
    Dim w1 As Workbook, w2 As Workbook
    Set w1 = ThisWorkbook
    Set w2 = Workbooks.Add
    w1.Activate
    For Each r In Intersect(Range("A:A"), ActiveSheet.UsedRange)
        v = r.Value
        If InStr(v, "First name") > 0 Then
            r.Copy w2.Sheets("Sheet1").Cells(K, 1)
            K = K + 1
        End If
    Next r
End Sub

The code opens a fresh workbook, goes back to the original workbook, runs down column A , and then copies the relevant cells to the fresh workbook.

EDIT#1

Here is the new macro:

Sub Luxation2()
    Dim K As Long, r As Range, v As Variant
    K = 1
    Dim w1 As Worksheet, w2 As Worksheet
    Set w1 = Sheets("raw data")
    Set w2 = Sheets("data manipulation")
    w1.Activate
    For Each r In Intersect(Range("A:A"), ActiveSheet.UsedRange)
        v = r.Value
        If InStr(v, "First name") > 0 Then
            r.Copy w2.Cells(K, 1)
            K = K + 1
        End If
    Next r
End Sub