Copy Row to new sheet based on list comparison

[skull_eagle]

Hi All,

I have a list of names in column A in sheet 2. I need to check for this name (all or part of name) in column C of Sheet 1. If the name is found then copy the row of data from sheet 1 to a new sheet (the new sheet should be called the search name). Once sheet 1 has been checked for the name in A1 (sheet2) then it needs to be checked for the name in A2 (Sheet2) and these should be copied to a new sheet..etc etc etc until all names have been checked and there are 50 or so new sheets.

I'm not sure if it's easier to do it this way or to instead create all the new sheets from the list in column A (Sheet 2) and then delete the blank ones after.

I'm having some major trouble and any assistance would be a life saver, Thanks

 

[VoG]

Try

Sub NameSearch()
Dim LR As Long, i As Long, Found As Boolean
Dim LR2 As Long, j As Long
LR2 = Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
With Sheets("Sheet2")
    LR = .Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To LR
        Found = False
        With .Range("A" & i)
            For j = 1 To LR2
                If InStr(.Value, Sheets("Sheet1").Range("C" & j).Value) > 0 Then
                    Found = True
                    Exit For
                End If
            Next j
            If Found Then
                Sheets.Add after:=Sheets(Sheets.Count)
                .EntireRow.Copy Destination:=ActiveSheet.Range("A1")
                On Error Resume Next
                ActiveSheet.Name = .Value
                On Error GoTo 0
            End If
        End With
    Next i
End With
End Sub

 

[skull_eagle]

Thank you so much for the code Peter.

A small problem,
I need it to copy over ever row that contains the name, the code appears to be only copying the first instance.
You also have ".EntireRow.Copy" in the code but it is only copying over the cell.

Any thoughts?


Thanks

 

[VoG]

For me it is copying the entire row.

It will also copy every instance. However, only with the first instance will the sheet be named with the name (worksheet names cannot be the same).

 

[skull_eagle]

I tried a few different things, it appears it is copying the entire Row from sheet 2 instead of sheet 1, sheet 2 is simply a list of the names and contains no data, I need the data to be copied from sheet 1. Is there a quick tweak I can make to the code to change this.

Thanks for your help.

 

[VoG]

Sorry, I thought Sheet2 was to be copied. Try

Sub NameSearch()
Dim LR As Long, i As Long, Found As Boolean
Dim LR2 As Long, j As Long
LR2 = Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
With Sheets("Sheet2")
    LR = .Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To LR
        Found = False
        With .Range("A" & i)
            For j = 1 To LR2
                If InStr(.Value, Sheets("Sheet1").Range("C" & j).Value) > 0 Then
                    Found = True
                    Exit For
                End If
            Next j
            If Found Then
                Sheets.Add after:=Sheets(Sheets.Count)
                Sheets("Sheet1").Range("C" & j).EntireRow.Copy Destination:=ActiveSheet.Range("A1")
                On Error Resume Next
                ActiveSheet.Name = .Value
                On Error GoTo 0
            End If
        End With
    Next i
End With
End Sub

 

[skull_eagle]

Thanks Peter, It is no copying from the data from sheet one.

I hate to be a pain but it is only copying over the first instance. 1 row per new tab, there should be several hundred....

 

[VoG]

Try this

Sub NameSearch()
Dim LR As Long, i As Long
Dim LR2 As Long, j As Long
LR2 = Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
With Sheets("Sheet2")
    LR = .Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To LR
        With .Range("A" & i)
            For j = 1 To LR2
                If InStr(.Value, Sheets("Sheet1").Range("C" & j).Value) > 0 Then
                    Sheets.Add after:=Sheets(Sheets.Count)
                    Sheets("Sheet1").Range("C" & j).EntireRow.Copy Destination:=ActiveSheet.Range("A1")
                    On Error Resume Next
                    ActiveSheet.Name = .Value
                    On Error GoTo 0
                End If
            Next j
        End With
    Next i
End With
End Sub

 

[skull_eagle]

Not quite.

For instance in A1 on sheet 2 was "abc". It's called sheet 3 "abc" as it should, copied 1 row in there and then copied the next row for "abc" to sheet 4 (still called sheet 4), next row to sheet 5 (still called sheet 5) up to sheet 29.

Then sheet 30 is called "def" for the A2 search and same thing - 1 row on that sheet, sheet 31 contains the next row for "def" etc up to sheet 100

Sheet 101 is called "ghi" etc etc etc.

 

[VoG]

Try

Sub NameSearch()
Dim LR As Long, i As Long
Dim LR2 As Long, j As Long
LR2 = Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
With Sheets("Sheet2")
    LR = .Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To LR
        With .Range("A" & i)
            For j = 1 To LR2
                If InStr(.Value, Sheets("Sheet1").Range("C" & j).Value) > 0 Then
                    If Not WorksheetExists(.Value) Then
                        Sheets.Add after:=Sheets(Sheets.Count)
                        On Error Resume Next
                        ActiveSheet.Name = .Value
                        On Error GoTo 0
                    End If
                    Sheets("Sheet1").Range("C" & j).EntireRow.Copy Destination:=ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1)
                End If
            Next j
        End With
    Next i
End With
End Sub


Function WorksheetExists(WSName As String) As Boolean
On Error Resume Next
WorksheetExists = Worksheets(WSName).Name = WSName
On Error GoTo 0
End Function