Select entire rows if between date/time range
This is how I would write the code. You have one line of code that I can't
resolve
Selection.Copy
I can't terll what is suppose to be selected.
Sub test()
Set EmailBk = Workbooks.Open(Filename:= _
"\\mascarolinabdc\puball\Data log trending Version 2.0\" & _
"email sheets\Cycle email P102.xls")
With EmailBk.Sheets("sheet1")
.Rows("3:200").ClearContents
End With
Set DataLogBk = Workbooks("Data log Trending V2.0.xls")
With DataLogBk
.Sheets("sheet2").Visible = True
.Sheets("sheet2").Range("B10") = _
FormulaR1C1 = "=NOW()-1"
End With
Set TrendingBk = Workbooks.Open(Filename:= _
"\\mascarolinabdc\puball\Data log trending Version 2.0\" & _
"Data log trending\P102 Datalog trending.xls")
With TrendingBk
.Sheets("Cycles with problems ").Visible = True
Dim sDate As Date, fDate As Date
Dim ws1 As Worksheet
Set ws1 = .Worksheets("Cycles with problems ") '<== Change as required
With ws1
'assumes dates are in colum A
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
End With
With .Worksheets("sheet2")
sDate = .Range("C30").Value
fDate = .Range("B30").Value
Set dateRng = .Range("a1:a" & lastrow)
r = Application.Match(CLng(sDate), dateRng, 1)
If IsError(r) Then
frow = 2 ' first row i.e. start date is before first date in
Column A
Else
frow = r
End If
lrow = Application.Match(CLng(fDate), dateRng, 1)
End With
End With
'---------------- what is suppose to be selected??? ---------------
Selection.Copy
'--------------------------------------------------------------------
With EmailBk.Sheets("sheet1")
.Range("A3").PasteSpecial
.Rows("3:3").Delete Shift:=xlUp
End With
With TrendingBk.Sheets("sheet2")
.Range("B30").Copy
.Range("C30").PasteSpecial _
Paste:=xlValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
Application.CutCopyMode = False
.Visible = False
End With
TrendingBk.Sheets("Cycles with problems ").Visible = False
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "Blank.com"
.CC = ""
.BCC = ""
.Subject = "P102 cycles with issue"
.Body = "Please see attached spread sheet for the latest " & _
"datalogs with issues"
.Attachments.Add ("\\mascarolinabdc\puball\Data log trending " & _
"Version 2.0\email sheets\Cycle email P102.xls")
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
With TrendingBk
.Sheets("sheet2").Visible = False
End With
EmailBk.Close savechanges:=True
With TrendingBk
.Close savechanges:=True
.Sheets("sheet2").Visible = False
.Sheets("sheet1").Select
End With
MsgBox ("Email sent")
End Sub
" wrote:
Hey,
I have a code that selects between two dates and then goes to another
sheet and looks for all cells (in colum A) that are between thoes
dates and copies the entire row into another spread sheet and emails
it.
Problem is that is not selecting the any of the lines.
Can you please take a look at my code and tell me what I am doing
wrong.
Thanks
----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Workbooks.Open Filename:= _
"\\mascarolinabdc\puball\Data log trending Version 2.0\email sheets
\Cycle email P102.xls"
Sheets("sheet1").Select
Rows("3:200").ClearContents
Workbooks("Data log Trending V2.0.xls").Activate
Sheets("sheet2").Visible = True
Sheets("sheet2").Select
Range("B10").Select
ActiveCell.FormulaR1C1 = "=NOW()-1"
Workbooks.Open Filename:= _
"\\mascarolinabdc\puball\Data log trending Version 2.0\Data log
trending\P102 Datalog trending.xls"
Sheets("Cycles with problems ").Visible = True
Workbooks("P102 Datalog trending.xls").Activate
Sheets("Cycles with problems ").Select
Dim sDate As Date, fDate As Date
Dim ws1 As Worksheet
Set ws1 = Workbooks("P102 Datalog trending.xls").Worksheets("Cycles
with problems ") '<== Change as required
ws1.Activate
With ws1
'assumes dates are in colum A
lastrow = .Cells(Rows.Count, 1).End(xlUp).row
sDate = Workbooks("Data log Trending
V2.0.xls").Worksheets("sheet2").Range("C30").Value
fDate = Workbooks("Data log Trending
V2.0.xls").Worksheets("sheet2").Range("B30").Value
Set dateRng = Range("a1:a" & lastrow)
r = Application.Match(CLng(sDate), dateRng, 1)
If IsError(r) Then
frow = 2 ' first row i.e. start date is before first date in
column A
Else
frow = r
End If
lrow = Application.Match(CLng(fDate), dateRng, 1)
End With
Selection.Copy
Workbooks("Cycle email P102.xls").Activate
Sheets("sheet1").Select
Range("A3").PasteSpecial
Rows("3:3").Select
Selection.Delete Shift:=xlUp
Workbooks("Data log Trending V2.0.xls").Activate
Sheets("sheet2").Select
Range("B30").Select
Selection.Copy
Range("C30").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Sheets("sheet2").Visible = False
Workbooks("Cycle email P102.xls").Activate
Workbooks("P102 Datalog trending.xls").Activate
Sheets("Cycles with problems ").Visible = False
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "Blank.com"
.CC = ""
.BCC = ""
.Subject = "P102 cycles with issue"
.Body = "Please see attached spread sheet for the latest
datalogs with issues"
.Attachments.Add ("\\mascarolinabdc\puball\Data log trending
Version 2.0\email sheets\Cycle email P102.xls")
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Workbooks("Data log Trending V2.0.xls").Activate
Sheets("sheet2").Visible = False
Workbooks("Cycle email P102.xls").Save
Workbooks("Cycle email P102.xls").Close
Workbooks("P102 Datalog trending.xls").Save
Workbooks("P102 Datalog trending.xls").Close
Workbooks("Data log Trending V2.0.xls").Activate
Sheets("sheet2").Visible = False
Sheets("sheet1").Select
MsgBox ("Email sent")
End Sub
----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
|