• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Macros to copy paste based on Select Words

srinidhi

Active Member
HI,

I have 3 tabs,in a workbook

Today, Completed & Not Completed.

In Today’s sheet the data starts from A 10 & goes upto Q 500.

Here I want to search for the words Completed & Not Completed & paste only Completed data in the Completed tab & the Not Completed data in the Not Completed Tab.

The data to these tabs will be updated on a daily basis, & it shld have the old data as well(Yesterday, day before …….

So in these tabs the macro has to find the first blank cell in column A & then paste the data from colum A to Q.
 
I'm assuming row 10 in the Today sheet is your header row. Here's a compilation of several small macros which should complete your task. Once you copy all of this to a module in the VBE, you can simply call the MainMacro from the workbook.

Code:
Sub MainMacro()

Application.ScreenUpdating = False

Worksheets("Today").Select

'Defines the range of data

ActiveSheet.Range("A10:Q500").AutoFilter

xCriteria = "Completed"

CopyData (xCriteria)

xCriteria = "Not completed"

CopyData (xCriteria)

TurnFilterOff

Application.ScreenUpdating = True

End Sub


Private Sub ShowAllRecords()

If ActiveSheet.FilterMode Then

ActiveSheet.ShowAllData

End If

End Sub


Private Sub TurnFilterOff()

'removes AutoFilter if one exists

ActiveSheet.AutoFilterMode = False

End Sub


Private Sub CopyFilter(xSheet As String)

'by Tom Ogilvy

Dim rng As Range

Dim rng2 As Range

With ActiveSheet.AutoFilter.Range

On Error Resume Next

Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _

.SpecialCells(xlCellTypeVisible)

On Error GoTo 0

End With

If rng2 Is Nothing Then

'Do nothing

Else

Set rng = ActiveSheet.AutoFilter.Range

rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy _

Destination:=Worksheets(xSheet).Cells(LastRow(1, xSheet) + 1, 1)

End If

End Sub


Private Sub CopyData(xCriteria As String)

ShowAllRecords

Range("A10").AutoFilter Field:=1, Criteria1:=xCriteria

CopyFilter (xCriteria)

End Sub


Function LastRow(x As Integer, Optional r As String) As Integer

'Find the last used row in a Column

Application.Volatile

If r = "" Then

r = ActiveSheet.Name

End If

With Worksheets(r)

LastRow = .Cells(.Rows.Count, x).End(xlUp).Row

End With

End Function
 
LUKE Thanks for the code, but is displaying 400 error, one thing I forgot to mention the

words Completed & Not Completed are in column M
 
Back
Top