Copy/Paste rows with specifc text in column d

I posted this to the wrong group yesterday. My apologies, I'm new to this.

I'm trying to write a macro that will bring up a text box to ask the user
what he/she is looking for (always text). The macro then looks through a
monster sheet of 7000 rows and copies every row that contains the text
string in column D, then deposits the rows into a new sheet. The
text string being searched for is a short piece within a longer string (ie.
'review' within 'project review').

This is what I have so far...I have not been able to copy/paste the row when
I get a hit.

Private Sub Copy_Paste_Rows_w_Match()
Dim ws As Worksheet
Dim targetws As Worksheet
Dim cl As Range, ctextalues As String, tRow As Long
Dim myvalue As String
Dim myrow As Range

If ActiveWorkbook Is Nothing Then Exit Sub

On Error Resume Next
If targetws Is Nothing Then
Set ws = ActiveSheet
Set SourceWB = ActiveWorkbook
Set targetws = Worksheets.Add.Worksheets(1)
Set targetws = ActiveSheet
SourceWB.Activate
ws.Activate
Set SourceWB = Nothing
End If

myvalue = InputBox("Find what?")

Set ws = ActiveSheet
For Each cl In ws.Range("D6:D7000").SpecialCells(xlConstants,
xlTextValues).Cells
ctextvalues = cl
If Len(ctextvalues) > 0 Then

If InStr(cl, myvalue) > 1 Then ctextvalues =
myrow.targetws.Activate.Cells.Range("A1") = myrow.ws.Activate
' This is where I am stuck. I have not been able to
copy/paste the row when I get a hit.
End If

Set cl = Nothing
End Sub

Hi Mike

There is code here
http://www.rondebruin.nl/copy5.htm

Try this example with the data on a sheet named "Sheet1"

Sub Copy_With_AutoFilter1()
Dim WS As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim Str As String

Set WS = Sheets("sheet1") '<<< Change
Set rng = WS.Range("D6:D7000") '<<< Change
Str = InputBox("Find what?")
If Str = "" Then Exit Sub


'Close AutoFilter first
WS.AutoFilterMode = False

'This example filter on the first column in the range (change the field if needed)
rng.AutoFilter Field:=1, Criteria1:="*" & Str & "*"

Set WSNew = Worksheets.Add
WS.AutoFilter.Range.Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With
WS.AutoFilterMode = False

On Error Resume Next
WSNew.Name = Str
If Err.Number > 0 Then
MsgBox "Change the name of : " & WSNew.Name & " manually"
Err.Clear
End If
On Error GoTo 0
End Sub




--
Regards Ron de Bruin
http://www.rondebruin.nl


"Mike Woodard" <[email protected]> wrote in message news:[email protected]...
>
> I posted this to the wrong group yesterday. My apologies, I'm new to this.
>
> I'm trying to write a macro that will bring up a text box to ask the user
> what he/she is looking for (always text). The macro then looks through a
> monster sheet of 7000 rows and copies every row that contains the text
> string in column D, then deposits the rows into a new sheet. The
> text string being searched for is a short piece within a longer string (ie.
> 'review' within 'project review').
>
> This is what I have so far...I have not been able to copy/paste the row when I get a hit.
>
> Private Sub Copy_Paste_Rows_w_Match()
> Dim ws As Worksheet
> Dim targetws As Worksheet
> Dim cl As Range, ctextalues As String, tRow As Long
> Dim myvalue As String
> Dim myrow As Range
>
> If ActiveWorkbook Is Nothing Then Exit Sub
>
> On Error Resume Next
> If targetws Is Nothing Then
> Set ws = ActiveSheet
> Set SourceWB = ActiveWorkbook
> Set targetws = Worksheets.Add.Worksheets(1)
> Set targetws = ActiveSheet
> SourceWB.Activate
> ws.Activate
> Set SourceWB = Nothing
> End If
>
> myvalue = InputBox("Find what?")
>
> Set ws = ActiveSheet
> For Each cl In ws.Range("D6:D7000").SpecialCells(xlConstants, xlTextValues).Cells
> ctextvalues = cl
> If Len(ctextvalues) > 0 Then
>
> If InStr(cl, myvalue) > 1 Then ctextvalues = myrow.targetws.Activate.Cells.Range("A1") = myrow.ws.Activate
> ' This is where I am stuck. I have not been able to copy/paste the row when I get a hit.
> End If
>
> Set cl = Nothing
> End Sub
>

Thanks! I think I can get this to work.


"Ron de Bruin" <[email protected]> wrote in message
news:[email protected]...
> Hi Mike
>
> There is code here
> http://www.rondebruin.nl/copy5.htm
>
> Try this example with the data on a sheet named "Sheet1"
>
> Sub Copy_With_AutoFilter1()
> Dim WS As Worksheet
> Dim WSNew As Worksheet
> Dim rng As Range
> Dim Str As String
>
> Set WS = Sheets("sheet1") '<<< Change
> Set rng = WS.Range("D6:D7000") '<<< Change
> Str = InputBox("Find what?")
> If Str = "" Then Exit Sub
>
>
> 'Close AutoFilter first
> WS.AutoFilterMode = False
>
> 'This example filter on the first column in the range (change the field
> if needed)
> rng.AutoFilter Field:=1, Criteria1:="*" & Str & "*"
>
> Set WSNew = Worksheets.Add
> WS.AutoFilter.Range.Copy
> With WSNew.Range("A1")
> ' Paste:=8 will copy the columnwidth in Excel 2000 and higher
> .PasteSpecial Paste:=8
> .PasteSpecial xlPasteValues
> .PasteSpecial xlPasteFormats
> Application.CutCopyMode = False
> .Select
> End With
> WS.AutoFilterMode = False
>
> On Error Resume Next
> WSNew.Name = Str
> If Err.Number > 0 Then
> MsgBox "Change the name of : " & WSNew.Name & " manually"
> Err.Clear
> End If
> On Error GoTo 0
> End Sub
>
>
>
>
> --
> Regards Ron de Bruin
> http://www.rondebruin.nl
>
>
> "Mike Woodard" <[email protected]> wrote in message
> news:[email protected]...
>>
>> I posted this to the wrong group yesterday. My apologies, I'm new to
>> this.
>>
>> I'm trying to write a macro that will bring up a text box to ask the user
>> what he/she is looking for (always text). The macro then looks through a
>> monster sheet of 7000 rows and copies every row that contains the text
>> string in column D, then deposits the rows into a new sheet. The
>> text string being searched for is a short piece within a longer string
>> (ie.
>> 'review' within 'project review').
>>
>> This is what I have so far...I have not been able to copy/paste the row
>> when I get a hit.
>>
>> Private Sub Copy_Paste_Rows_w_Match()
>> Dim ws As Worksheet
>> Dim targetws As Worksheet
>> Dim cl As Range, ctextalues As String, tRow As Long
>> Dim myvalue As String
>> Dim myrow As Range
>>
>> If ActiveWorkbook Is Nothing Then Exit Sub
>>
>> On Error Resume Next
>> If targetws Is Nothing Then
>> Set ws = ActiveSheet
>> Set SourceWB = ActiveWorkbook
>> Set targetws = Worksheets.Add.Worksheets(1)
>> Set targetws = ActiveSheet
>> SourceWB.Activate
>> ws.Activate
>> Set SourceWB = Nothing
>> End If
>>
>> myvalue = InputBox("Find what?")
>>
>> Set ws = ActiveSheet
>> For Each cl In ws.Range("D6:D7000").SpecialCells(xlConstants,
>> xlTextValues).Cells
>> ctextvalues = cl
>> If Len(ctextvalues) > 0 Then
>>
>> If InStr(cl, myvalue) > 1 Then ctextvalues =
>> myrow.targetws.Activate.Cells.Range("A1") = myrow.ws.Activate
>> ' This is where I am stuck. I have not been able to
>> copy/paste the row when I get a hit.
>> End If
>>
>> Set cl = Nothing
>> End Sub
>>
>
>