Copy/Paste rows with specifc text in column d

[Mike Woodard]

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("D67000").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

 

[Ron de Bruin]

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("D67000") '<<< 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

 

[Mike Woodard]

Thanks! I think I can get this to work.

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("D67000") '<<< 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