put cells based on condition in sheet2

[jhahes]

Could someone please help me do the following....

In Sheet1 column a I have about 5000 entries.....What I would like t
do is have a code that loops thru all entries...all entries would b
text strings...

if it finds info411.com in any part of the cell then cut and paste i
it shee2 column a in the first open cell....then repeat the proces
thru the loop.

so if 200 cells in Sheet1 Column A contained infro411.com then the
would be cut and there would be 200 cells in Sheet2 Column a that woul
now contain them...

thank you for any hel

 

[Ron de Bruin]

Hi jhahes

You can use Autofilter

Try this with the data in column A of Sheet1
A1 is the header cell


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
'A1 is the top left cell of your filter range and the header of the first column
Set rng = WS.Range("A1").CurrentRegion '<<< Change
Str = "*infro411.com*" '<<< Change

'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

 

[jhahes]

Thank you Ron for the code....It worked great, however,

is there anyway it can delete the row that it copies from....on Sheet1


thanks

Jos

 

[Ron de Bruin]

Test this one Josh

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

Set WS = Sheets("sheet1") '<<< Change
'A1 is the top left cell of your filter range and the header of the first column
Set rng = WS.Range("A1").CurrentRegion '<<< Change
Str = "*infro411.com*" '<<< Change

'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

With WS.AutoFilter.Range
On Error Resume Next
Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng2 Is Nothing Then
rng2.EntireRow.Delete
End If
End With

WS.AutoFilterMode = False

End Sub

 

[Ron de Bruin]

See also
http://www.rondebruin.nl/copy5.htm

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

Test this one Josh

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

Set WS = Sheets("sheet1") '<<< Change
'A1 is the top left cell of your filter range and the header of the first column
Set rng = WS.Range("A1").CurrentRegion '<<< Change
Str = "*infro411.com*" '<<< Change

'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

With WS.AutoFilter.Range
On Error Resume Next
Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng2 Is Nothing Then
rng2.EntireRow.Delete
End If
End With

WS.AutoFilterMode = False

End Sub

 

[jhahes]

thanks Ron - the code worked great!

 

[Ron de Bruin]

Hi Josh

I add the delete code also to the macro on my site in the first example
http://www.rondebruin.nl/copy5.htm