Find Multiple Values And Copy Entire Row

[Jaye7]

Hi All,

I am after a script that looks for the following values ANYWHERE within Sheet1, not just in column A

If it finds the value then it copies the entire row to the next avalable row on Sheet2.

Values need to be non case sentence and are anywhere within the cell, i.e the sentence "the loss of DB1085 was?" might be in the cell, it needs to look for the word "DB1085" and copy that whole row to Sheet2.

Values that it looks for are.

DB1085
JK1345
CD1925
AR0035

Thanks

 

[P.Holko]

Hi, try this procedure. Hope it helps.

Sub CopyEntireRow()

Dim CellR As Range
Dim strName As String

strName = InputBox(Prompt:="Enter string", Title:="??", Default:="DB1085")

For Each CellR In Worksheets("Sheet1").UsedRange

    If InStrRev(CellR.Value, strName, -1, vbTextCompare) <> 0 Then
    
        LastRow = Sheets("Sheet2").Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious).Row + 1
        Sheets("Sheet2").Rows(LastRow & ":" & LastRow).Value = CellR.EntireRow.Value
        
    End If
    
Next

End Sub

 

[Jaye7]

Hi P.Holko,

This scripts works great except for the following.

Can the string name be the specified values (without input box) so that I do not have to type them all in each time, having to run the script 4 times.

Values were.

DB1085
JK1345
CD1925
AR0035

Also

If there is no initial line of data in sheet2 it is bugging out saying variable widthblock not set.

[COLOR=red]LastRow = Sheets("Sheet2").Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious).Row + 1[/COLOR]

Thanks

 

[P.Holko]

This should works better

Sub CopyEntireRow()

On Error Resume Next

Dim CellR As Range
Dim strName As String
ReDim arr(4) As String
LastRow = 1
arr(1) = "DB1085"
arr(2) = "JK1345"
arr(3) = "CD1925"
arr(4) = "AR0035"

For i = 1 To 4
    strName = arr(i)
    
    For Each CellR In Worksheets("Sheet1").UsedRange

        If InStrRev(CellR.Value, strName, -1, vbTextCompare) <> 0 Then
    
            LastRow = Sheets("Sheet2").Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious).Row + 1
            Sheets("Sheet2").Rows(LastRow & ":" & LastRow).Value = CellR.EntireRow.Value
        
        End If
    
    Next
    
Next i

End Sub

 

[Jaye7]

That is almost perfect, the only problem is if there is no data in Sheet2, (as sometimes it may be empty), then the variable width block error is still happening.

 

[P.Holko]

Is it still happening? 'runtime error 91'?
well, works fine on my Excel 2007 (even if Sheet2 is empty).
Did You copy entire procedure to Your module?
the lines with:

On Error Resume Next

and

LastRow = 1

should solve the problem.

 

[P.Holko]

and there is another way to solve the problem with 'empty' sheet:

Sub CopyEntireRow()

Dim CellR As Range
Dim strName As String
ReDim arr(4) As String

arr(1) = "DB1085"
arr(2) = "JK1345"
arr(3) = "CD1925"
arr(4) = "AR0035"

For i = 1 To 4
    strName = arr(i)
    
    For Each CellR In Worksheets("Sheet1").UsedRange

        If InStrRev(CellR.Value, strName, -1, vbTextCompare) <> 0 Then
            If WorksheetFunction.CountA(Worksheets("Sheet2").Cells) = 0 Then
                LastRow = 1
            Else
                LastRow = Sheets("Sheet2").Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious).Row + 1
            End If
            Sheets("Sheet2").Rows(LastRow & ":" & LastRow).Value = CellR.EntireRow.Value
        
        End If
    
    Next
    
Next i

End Sub

Is it works?

 

[Jaye7]

I copied the whole script, It is working fine in 2007 on my 2007 session, for some reason it won't work properly in 2010.

I have found 2010 has lot's of problems with scripts that should work fine.

 

[Jaye7]

The new script is perfect, thanks very much for your time and help.

 

[P.Holko]

You're welcome.
regards