copy data to another sheet

[Jock]

I'm still trying to sort this one out - but using a new approach.

Once every few days, I want a user to click a button which will run a macro
which will:
check columns A:C for certain words (black, white, green).

If any of these words are found in any row, to then enter today's date in a
cell on the same row offset by (0 ,22) unless that cell already has a date in
it from a previous running of this macro

To then search the column with the offset dates for 'todays' date and copy
the entire row to Sheet!2 but only those rows which have the same date as
'today'.

To colour all rows copied over grey so they stand out (or put a bold line at
the top of the first row to be copied over).

I hope this makes sense as I have been struggling for a while now.

 

[Joel]

Sub RunOnceADay()

wordlist = Array("black", "white", "green")

With Sheets("Sheet1")
'use column IV as a filter to indicate rows that have changed
.Columns("IV").Delete
For Each wd In wordlist
Set c = .Columns("A:C").Find(what:=wd, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then

firstaddr = c.Address
Do
If c.Offset(0, 22) = "" Then
c.Offset(0, 22) = Date
'put an x in column IV for rows with todays date
.Range("IV" & c.Row) = "X"
End If

Loop While Not c Is Nothing And c.Address <> firstaddr
End If
Next wd
'filter on column IV containing a "X"
LastRow = .Range("IV").End(xlUp).Row
.Columns("IV").AutoFilter Field:=1, Criteria1:="X"
.Rows("2:" & LastRow).SpecialCells(xlCellTypeVisible).Copy
End With

With Sheets("Sheet2")
LastRow = .Range("A").End(xlUp).Row
Newrow = LastRow + 1
.Rows(Newrow).Paste
LastRow = .Range("A").End(xlUp).Row
.Rows(Newrow & ":" & LastRow).Interior.ColorIndex = 15

End With


End Sub

 

[Jock]

Hi Joel,
This looks very promising!
I have received an "Application-defined or object-defined error" though, on
line 26 - LastRow = .Range("IV").End(xlUp).Row - can't see why tho.
Could it be because the offset dates span three columns depending on which
of A, B or C the words were found in?
Only the first row has an X in column IV ( although I expected an X to
appear in the second and third rows too as there was dummy data in A, B and C)

Thanks
Traa Dy Liooar

Jock

 

[Jock]

Just reset the code and tried again.
This time, although I still get the same error message (line 26), there are
three X's as expected in the first three rows in IV.

 

[Joel]

made a typo on Lasdt line in a few places. I also added the delete of
column IV at the end.

Sub RunOnceADay()

wordlist = Array("black", "white", "green")

With Sheets("Sheet1")
'use column IV as a filter to indicate rows that have changed
.Columns("IV").Delete
For Each wd In wordlist
Set c = .Columns("A:C").Find(what:=wd, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then

firstaddr = c.Address
Do
If c.Offset(0, 22) = "" Then
c.Offset(0, 22) = Date
'put an x in column IV for rows with todays date
.Range("IV" & c.Row) = "X"
End If

Loop While Not c Is Nothing And c.Address <> firstaddr
End If
Next wd
'filter on column IV containing a "X"
LastRow = .Range("IV" & Rows.Count).End(xlUp).Row
.Columns("IV").AutoFilter Field:=1, Criteria1:="X"
.Rows("2:" & LastRow).SpecialCells(xlCellTypeVisible).Copy
End With

With Sheets("Sheet2")
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
Newrow = LastRow + 1
.Rows(Newrow).Paste
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
.Rows(Newrow & ":" & LastRow).Interior.ColorIndex = 15

End With

With Sheets("Sheet1")
.Columns("IV").Delete
End With

End Sub

 

[Jock]

Got further down now to line 36 - .Rows(Newrow).Paste

Also, how do I get the auto filter to revert back to how it was originally
(ie with no filter) once rows have been copied over?

 

[Joel]

Mot sure why but had to use pastespecial instead of paste. Also added the
removal of the autofilter.

Sub RunOnceADay()

wordlist = Array("black", "white", "green")

With Sheets("Sheet1")
'use column IV as a filter to indicate rows that have changed
.Columns("IV").Delete
For Each wd In wordlist
Set c = .Columns("A:C").Find(what:=wd, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then

firstaddr = c.Address
Do
If c.Offset(0, 22) = "" Then
c.Offset(0, 22) = Date
'put an x in column IV for rows with todays date
.Range("IV" & c.Row) = "X"
End If

Loop While Not c Is Nothing And c.Address <> firstaddr
End If
Next wd
'filter on column IV containing a "X"
LastRow = .Range("IV" & Rows.Count).End(xlUp).Row
.Columns("IV").AutoFilter Field:=1, Criteria1:="X"
.Rows("2:" & LastRow).SpecialCells(xlCellTypeVisible).Copy

End With

With Sheets("Sheet2")
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
Newrow = LastRow + 1
.Rows(Newrow).PasteSpecial _
Paste:=xlPasteValues
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
.Rows(Newrow & ":" & LastRow).Interior.ColorIndex = 15
.Columns("IV").AutoFilter
End With

With Sheets("Sheet1")
.Columns("IV").Delete
End With

End Sub

 

[Jock]

Nice one - many thanks Joel.
One last thing, can the PasteValues part be adapted to include formatting
from sheet!1? The reason being that there are dates and other stuff formatted
in different ways which I'd like copied accross too.

Thanks again.

 

[Joel]

from
.Rows(Newrow).PasteSpecial _
Paste:=xlPasteValues
to
.Rows(Newrow).PasteSpecial _
Paste:=xlPasteValues
.Rows(Newrow).PasteSpecial _
Paste:=xlPasteFormats

 

[Jock]

Cool, Thanks
--
Traa Dy Liooar

Jock

from
.Rows(Newrow).PasteSpecial _
Paste:=xlPasteValues
to
.Rows(Newrow).PasteSpecial _
Paste:=xlPasteValues
.Rows(Newrow).PasteSpecial _
Paste:=xlPasteFormats