PDA

View Full Version : Solved: Select Rows by Date



GaryB
06-09-2006, 08:27 AM
Hi,
I know enough about Excel to get myself in trouble and I don't even know if this is possible. I have a workbook with mulitple worksheets. Column B is conditionally formatted to automatically highlight the current date. What I want to do is to set a macro or vba code to copy the current date row from each worksheet to a master sheet. This is a schedule board and it would allow me to isolate the current day's scheduling. I have attached a sample workbook. Any help or insight is always appreciated.

Thanks

Gary3251

mdmackillop
06-09-2006, 08:46 AM
With your MasterSheet as the first in the workbook try the following. It assumes a date will appear only once in each sheet. The code must be run from the Master Sheet


Sub CopyRows()
Dim i As Long
For i = 2 To Sheets.Count
With Sheets(i)
.Columns(2).Find(what:=Format(Now(), _
("m/d"))).EntireRow.Copy Cells(65536, 1).End(xlUp).Offset(1)
End With
Next
End Sub

GaryB
06-09-2006, 11:44 AM
I'm going to apologize ahead of time. Sorry! What do I do with the code? I can see create the mastersheet and then do I add the code to sheet or to a macro? This is really new for me in excel. Can you tell?

Thanks,

Gary

Cyberdude
06-09-2006, 04:30 PM
Gary, Malcolm has provided the basic stuff you need to write a VBA macro. I'm not sure how you want to invoke it. You can create a button and assign the macro name to the button, or you can call the macro from another macro if that's more appropriate. Probably the button option would be best to start out with to see how it works and to allow you to run it any time you want to. Or you can access the list of macros and "Run" it it as needed. If you are new to VBA, then I can see how you are maybe a bit confused.
Regards, Sid

mdmackillop
06-09-2006, 04:40 PM
See sample

GaryB
06-12-2006, 01:46 PM
Thank you MD,

It worked perfectly. Amazing what you can do if you, and I mean YOU!, know what you're doing. Out of curiosity, is there a way to prompt for a particular date?

Thank you again,

Gary

mdmackillop
06-12-2006, 02:29 PM
Just add an InputBox


Sub CopyRows()
Dim i As Long, MyDate As String
MyDate = InputBox("Enter date in m/d format", "CopyData", Format(Now(), "m/d"))
For i = 2 To Sheets.Count
With Sheets(i)
.Columns(2).Find(what:=MyDate) _
.EntireRow.Copy Cells(65536, 1).End(xlUp).Offset(1)
End With
Next
End Sub

GaryB
06-12-2006, 04:05 PM
My thank you to you didn't post, so, here it is again. The input box worked wonderfully. Thank you for all the help, it is gratefully appreciated.:bow:

Gary

GaryB
06-16-2006, 01:35 PM
Hi,
I'm not sure if re-posting something that has been checked solved is kosher, but I have a question directly relating to this and I thought this might be easier than a new post. If I am wrong about this I apologize profusely.

The code for this has worked beautifullly, my question now is, if I change colors in the cells, is there any way to paste them back to their original places and worksheets with the changed colors?

Thanks

Gary

mdmackillop
06-16-2006, 02:40 PM
Try the attached

GaryB
06-16-2006, 04:25 PM
MD, it worked absolutely perfectly. How you do this so quickly boggles my mind. Thank you again and again and again.................

Gary

mdmackillop
06-16-2006, 04:34 PM
Answering questions and seeing other approaches gets me a breadth of knowledge and practice I could never get just solving my own problems, and it's surprising how often I can then make use of the things I've learned to help at my work.

GaryB
06-20-2006, 07:27 AM
Hi MD,

A question please. On today's date ( 6/20) it loads 12/6 and if I delete all of December, it loads 1/6. Do you think changing the conditional formatting on the press sheets to mm/dd/yy might be a better way to go?

Thanks

Gary

GaryB
06-20-2006, 07:56 AM
MD,

I changed the code on the dates to this:
Sub CopyRows()
Dim i As Long, MyDate As String
MyDate = InputBox("Enter date in m/d/yy format", "CopyData", Format(Now(), "m/d/yy"))
For i = 2 To Sheets.Count
With Sheets(i)
.Columns(2).Find(what:=MyDate) _
.Range("A1:IU1").Copy Cells(65536, 1).End(xlUp).Offset(1, 1)
Cells(65536, 1).End(xlUp).Offset(1) = Sheets(i).Name
End With
Next
End Sub
And I get this error message:

run-time error 91
Object variable or with block variable not set

I also formatted the cells on each work sheet so the dates would show m/d/yy.

Any suggestions?:banghead:

Thanks again
Gary

mdmackillop
06-20-2006, 11:46 AM
Hi Gary,
This seems to work.

Sub CopyRows()
Dim i As Long, MyDate
MyDate = InputBox("Enter date in m/d/yy format", "CopyData", Format(Now(), "m/d/yy"))
For i = 2 To Sheets.Count
With Sheets(i)
.Columns(2).Find(what:=Format(MyDate, "m/d")) _
.Range("A1:IU1").Copy Cells(65536, 1).End(xlUp).Offset(1, 1)
Cells(65536, 1).End(xlUp).Offset(1) = Sheets(i).Name
End With
Next
End Sub

GaryB
06-20-2006, 12:03 PM
Hi MD,

When you ran this code, did it come up with 6/20 as the date? When I ran it still came up 12/6. I know I'm missing something!

Thanks

Gary

mdmackillop
06-20-2006, 12:08 PM
I suspect we're having date compatability problems. We need another ex-colonial to help out here I think!

mvidas
06-20-2006, 12:39 PM
I think part of it may also have to do with what is being searched (Format(MyDate, "m/d")) which is searching for text (as today would be "6/20").. since there is nothing specifying to search the entire cell contents, it finds "6/20" as part of "12/6/2005"
Change the Find/Copy line to: .Columns(2).Find(What:=DateValue(MyDate), LookAt:=xlWhole) _
.Range("A1:IU1").Copy Cells(65536, 1).End(xlUp).Offset(1, 1)You should be all set!
Matt

lucas
06-20-2006, 12:39 PM
....I get 12/6 and coresponding data also.....looking further.

lucas
06-20-2006, 12:42 PM
that has corrected it Matt...

mvidas
06-20-2006, 01:04 PM
Using DateValue like that should allow people on both sides of the pond to use it too :)

GaryB
06-20-2006, 02:17 PM
Hi Matt and Lucas. This fix worked great. I had to combine what MD and Matt did
Sub CopyRows()
Dim i As Long, MyDate
MyDate = InputBox("Enter date in m/d/yy format", "CopyData", Format(Now(), "m/d/yy"))
For i = 2 To Sheets.Count
With Sheets(i)
.Columns(2).Find(What:=DateValue(MyDate), LookAt:=xlWhole) _
.Range("A1:IU1").Copy Cells(65536, 1).End(xlUp).Offset(1, 1)
Cells(65536, 1).End(xlUp).Offset(1) = Sheets(i).Name
End With
Next
End Sub
and it works great!!!!!!!! Thanks to everyone. What a Forum...
This 2nd code is what MD gave me to paste changes back into the schedule sheets.
Sub COPYBACK()
Dim i As Long, MyDate As String, M1 As Range, M2 As Range, M3 As Range, M4 As Range, M5 As Range, M6 As Range, M7 As Range
Dim rQP As Range, r52 As Range, r46 As Range, r272 As Range, r472 As Range, rletterpress As Range, rIndigo As Range, sh As String
MyDate = InputBox("Enter date in m/d format", "CopyData", Format(Now(), "m/d"))
If MyDate = "" Then Exit Sub
On Error Resume Next
Set M1 = Columns(2).Find(What:=MyDate)
Set M2 = Columns(2).Find(What:=MyDate, after:=M1)
Set M3 = Columns(2).Find(What:=MyDate, after:=M2)
Set M4 = Columns(2).Find(What:=MyDate, after:=M3)
Set M5 = Columns(2).Find(What:=MyDate, after:=M4)
Set M6 = Columns(2).Find(What:=MyDate, after:=M5)
Set M7 = Columns(2).Find(What:=MyDate, after:=M6)
If M1 Is Nothing And M2 And M3 Is Nothing And M4 Is Nothing And M5 Is Nothing And M6 Is Nothing And M7 Is Nothing Then
MsgBox "Please check date."
COPYBACK
End If
Set rQP = Sheets("QP").Columns(2).Find(What:=MyDate)
Set r52 = Sheets("52").Columns(2).Find(What:=MyDate)
Set r46 = Sheets("46").Columns(2).Find(What:=MyDate)
Set r272 = Sheets("272").Columns(2).Find(What:=MyDate)
Set r472 = Sheets("472").Columns(2).Find(What:=MyDate)
Set rletterpress = Sheets("letterpress").Columns(2).Find(What:=MyDate)
Set rIndigo = Sheets("Indigo").Columns(2).Find(What:=MyDate)

M1.Range("A1:IU1").Copy rQP
M2.Range("A1:IU1").Copy r52
M3.Range("A1:IU1").Copy r46
M4.Range("A1:IU1").Copy r272
M5.Range("A1:IU1").Copy r472
M6.Range("A1:IU1").Copy rletterpress
M7.Range("A1:IU1").Copy rIndigo
End Sub

it is now giving me a check date error. Do I need to do the same change what was done on the first code?

Thanks to everyone.

Gary

GaryB
06-21-2006, 06:43 AM
I am in debt to all whole helped on this. I did figure out how to make the copy back work, thanks to all of you, here is the code with the changes that were suggested above.

A heartfelt thank you once again,

Gary

Sub COPYBACK()
Dim i As Long, MyDate As String, M1 As Range, M2 As Range, M3 As Range, M4 As Range, M5 As Range, M6 As Range, M7 As Range
Dim rQP As Range, r52 As Range, r46 As Range, r272 As Range, r472 As Range, rletterpress As Range, rIndigo As Range, sh As String
MyDate = InputBox("Enter date in m/d/YY format", "CopyData", Format(Now(), "m/d/YY"))
If MyDate = "" Then Exit Sub
On Error Resume Next
Set M1 = Columns(2).Find(What:=DateValue(MyDate), LookAt:=xlWhole)
Set M2 = Columns(2).Find(What:=DateValue(MyDate), LookAt:=xlWhole, after:=M1)
Set M3 = Columns(2).Find(What:=DateValue(MyDate), LookAt:=xlWhole, after:=M2)
Set M4 = Columns(2).Find(What:=DateValue(MyDate), LookAt:=xlWhole, after:=M3)
Set M5 = Columns(2).Find(What:=DateValue(MyDate), LookAt:=xlWhole, after:=M4)
Set M6 = Columns(2).Find(What:=DateValue(MyDate), LookAt:=xlWhole, after:=M5)
Set M7 = Columns(2).Find(What:=DateValue(MyDate), LookAt:=xlWhole, after:=M6)
If M1 Is Nothing And M2 And M3 Is Nothing And M4 Is Nothing And M5 Is Nothing And M6 Is Nothing And M7 Is Nothing Then
MsgBox "Please check date."
COPYBACK
End If
Set rQP = Sheets("QP").Columns(2).Find(What:=DateValue(MyDate), LookAt:=xlWhole)
Set r52 = Sheets("52").Columns(2).Find(What:=DateValue(MyDate), LookAt:=xlWhole)
Set r46 = Sheets("46").Columns(2).Find(What:=DateValue(MyDate), LookAt:=xlWhole)
Set r272 = Sheets("272").Columns(2).Find(What:=DateValue(MyDate), LookAt:=xlWhole)
Set r472 = Sheets("472").Columns(2).Find(What:=DateValue(MyDate), LookAt:=xlWhole)
Set rletterpress = Sheets("letterpress").Columns(2).Find(What:=DateValue(MyDate), LookAt:=xlWhole)
Set rIndigo = Sheets("Indigo").Columns(2).Find(What:=DateValue(MyDate), LookAt:=xlWhole)

M1.Range("A1:IU1").Copy rQP
M2.Range("A1:IU1").Copy r52
M3.Range("A1:IU1").Copy r46
M4.Range("A1:IU1").Copy r272
M5.Range("A1:IU1").Copy r472
M6.Range("A1:IU1").Copy rletterpress
M7.Range("A1:IU1").Copy rIndigo
End Sub