Copy paste data based on criteria

[analyst]

For the same database, I've one more query, If i could automate that through macro. Though it is on different subject, since you are here, I'm taking liberty to avoid creating new thread.

Say, in a sheet1, I've 6000+ row data, which i could ditinguish on two words contains in Column E, Which is either "XX", or "YY".

I've to select all rows where cell content in column E has word "XX" (without quote) and select, copy that and paste in say sheet2 from A1, and then again comeback to Sheet1, and select all those rowas where cell content in Column E has word "YY" (without quote) and select, copy and paste in Sheet3, cell A1.

While i tried with auto filter, at first hit, i am able to do this, as on few occassion word "xx" starts from row 2 itself, but when it starts from other row number, i am not able to select rest of the rows having word yy and do the work.

Any small procedure to do this? I am searching the forum, may be, similar query would have been resolved!

[Admin]

Hi

Come up with the macro you have now.

[analyst]

Through Google search, I found solution to my second query from this thread on another forum,

Copy entire row if Cell(Cells) in row contains specific string (http://www.ozgrid.com/forum/showthread.php?t=177044)

[littleiitin]

Try this




Sub FilterData()

Dim rngFilterRange As Range
Dim rngToCopy As Range
With Sheet1
If .AutoFilterMode = True Then .AutoFilterMode = False

Set rngFilterRange = .Range("A1").CurrentRegion
'=============For xx==================================
'====Applied Filter for Words contains XX ===========
rngFilterRange.AutoFilter Field:=5, Criteria1:="=*xx*", Operator:=xlAnd

'=====Creating Range to Copy ========
Set rngToCopy = .Range("A1").CurrentRegion.Offset(1).SpecialCells(xlCellTypeV isible)
'=====Copying Range =================
rngToCopy.Copy
'=====Pasting Data in Sheet 2 ==================
Sheet2.Range("A" & .Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteAll



'=============For yy==================================
If .AutoFilterMode = True Then .AutoFilterMode = False
'====Applied Filter for Words contains yy ===========
rngFilterRange.AutoFilter Field:=5, Criteria1:="=*yy*", Operator:=xlAnd

'=====Creating Range to Copy ========
Set rngToCopy = .Range("A1").CurrentRegion.Offset(1).SpecialCells(xlCellTypeV isible)
'=====Copying Range =================
rngToCopy.Copy
'=====Pasting Data in Sheet 3 ==================
Sheet3.Range("A" & .Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteAll

If .AutoFilterMode = True Then .AutoFilterMode = False

End With
End Sub

[analyst]

@ Thanks for your above code, littletin.

Last question, Is there any smartway to filter Date (read from Cell O2), and delete all rows within range A:O, including Cell O2, where similar date is found in Column O?

[analyst]

My Current code is as under,


Sub deleterow()
Dim dt As Date, x As Date

Sheets("raw").Select
x = Range("O2")

[O:O].AutoFilter Field:=1, Criteria1:=x 'filters on column O where cell contains some date
With ActiveSheet.AutoFilter.Range
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete
End With '

ActiveSheet.AutoFilterMode = False 'turns off autofilter
End Sub


The issue,

1) It filters date but does not recognise the date format as dd-mmm-yy (filter mode shows criteria equals m/d/yyyy)
2) When I select date manually, rest of the code gets executed to delete rows, but still it leaves first row as undeleted where the criteria is also matched.

What modification, do i need to make, and in which part of the macro?

[littleiitin]

Try This:



Sub FindandDelete()

Dim rngMakeRange As Range
Dim lngCnt As Long
Dim rngFindNext As Range
Dim rngCheck As Range
Dim dicRow As Object

Set dicRow = CreateObject("Scripting.Dictionary")
With Sheet1
Set rngFindNext = .Range("A:O").Find(.Range("O2").Value)
Set rngMakeRange = rngFindNext
dicRow.Add rngFindNext.Row, 1
Do Until Not Intersect(rngMakeRange, .Range("A:O").FindNext(rngFindNext)) Is Nothing
Set rngFindNext = .Range("A:O").FindNext(rngFindNext)
If Not dicRow.Exists(rngFindNext.Row) Then
dicRow.Add rngFindNext.Row, 1
If rngMakeRange Is Nothing Then
Set rngMakeRange = rngFindNext
Else
Set rngMakeRange = Union(rngMakeRange, rngFindNext)
End If
End If
Loop
End With
rngMakeRange.EntireRow.Delete

End Sub

[analyst]

Thanks, but after execution, nothing happens, sheet data remains as it was before.