Code that searches a column, then copies and pastes any matches intoa new Spreadsheet

[Mike C]

Hello - Does anyone happen to have some code that would allow me to
search a single column for a given word or number, and then copy and
paste the entire row for the matches?

It doesn't have to be perfect, so please feel free to send me anything
that is similar.

But to give an example. I would like to be able to search column A for
the word "apple" and then for cell in column A that has "apple" in it,
I would like to see the entire row pasted in Worksheet 2. I would
prefer to be able to use a data entry box or some other prompt to
enter the text (or number) after pressing a button----but I am not
being picky.

Thanks for any code you may have available, even if it only does
something similar.

- M

 

[Mike H]

Hi,

Put this in a module. Alt+F11 to open VB editor. Right click 'This workbook'
insert module and paste this in

Sub copyit()
response = InputBox("Search for what")
Dim MyRange, MyRange1 As Range
Sheets("Sheet1").Select
lastrow = Sheets("Sheet1").Range("A65536").End(xlUp).Row
Set MyRange = Sheets("Sheet1").Range("A1:A" & lastrow)
For Each c In MyRange
If UCase(CStr(c.Value)) = UCase(response) Then
If MyRange1 Is Nothing Then
Set MyRange1 = c.EntireRow
Else
Set MyRange1 = Union(MyRange1, c.EntireRow)
End If
End If
Next
MyRange1.Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
End Sub

Mike

 

[JLGWhiz]

'Copies from column of mixed data based on criteria
'in adjacent column and pastes into nest available
'cell column A on another sheet.


Sub CpyPstTst1()
Worksheets(1).Activate
Dim i, lr1, lr2 As Long
lr1 = Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row
For i = 1 To lr1
lr2 = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row
If Worksheets(1).Cells(i, 2).Value = "Apple" Then
Cells(i, 1).Copy Worksheets(2).Cells(lr2 + 1, 1)
End If
Next i
Application.CutCopyMode = False
End Sub

 

[Mike H]

Correction. I've assumed not Excel 2007 and shouldn't have and omitted a bit
of an error trap

Sub copyit()
response = InputBox("Search for what")
Dim MyRange, MyRange1 As Range
Sheets("Sheet1").Select
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Set MyRange = Sheets("Sheet1").Range("A1:A" & lastrow)
For Each c In MyRange
If UCase(CStr(c.Value)) = UCase(response) Then
If MyRange1 Is Nothing Then
Set MyRange1 = c.EntireRow
Else
Set MyRange1 = Union(MyRange1, c.EntireRow)
End If
End If
Next
If MyRange1 Is Nothing Then
MsgBox ("No Matches for " & response)
Exit Sub
End If
MyRange1.Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
End Sub


Mke H

 

[JLGWhiz]

You wanted the entire row copied. Sorry, here is revision.


'Copies from column of mixed data based on criteria
'in adjacent column and pastes into nest available
'cell column A on another sheet.


Sub CpyPstTst1()
Worksheets(1).Activate
Dim i, lr1, lr2 As Long
lr1 = Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row
For i = 1 To lr1
lr2 = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row
If Worksheets(1).Cells(i, 2).Value = "Apple" Then
Cells(i, 1).EntireRow.Copy Worksheets(2).Cells(lr2 + 1, 1)

End If
Next i
Application.CutCopyMode = False
End Sub

 

[Mike C]

You wanted the entire row copied.  Sorry, here is revision.

'Copies fromcolumnof mixed data based on criteria
'in adjacentcolumnand pastes into nest available
'cellcolumnA on another sheet.

Sub CpyPstTst1()                      
    Worksheets(1).Activate      
    Dim i, lr1, lr2 As Long
    lr1 = Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row
    For i = 1 To lr1
      lr2 = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row        
        If Worksheets(1).Cells(i, 2).Value = "Apple" Then
          Cells(i, 1).EntireRow.Copy Worksheets(2).Cells(lr2 + 1, 1)        

        End If
    Next i
    Application.CutCopyMode = False
End Sub









- Show quoted text -

Thanks very much for the replies!!!