Copy paste data based on criteria

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!

Hi

Come up with the macro you have now.

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

Try this

Code:

---


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(xlCellTypeVisible)
        '=====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(xlCellTypeVisible)
        '=====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

---

@ 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?

My Current code is as under,

Code:

---

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?

Try This:

Code:

---

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

---

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