I have the code listed later in this post. I am trying to incorporate within the for next loop to look if column J is blank and column k is not blank(if both criteria are met then it sets up an appointment in outlook then loops, if not then it simply loops and goes to the next row.The code I currently am using to try to accomplish this is in bold. If you try to run this code, it will not work unless the workbook is set up the way I have it set up, as their are references to other data from separate sheets. Thank you in advance.
Sub CreateAppointment()
Dim WS As Worksheet
Dim LastCellA As Range, LastCellB As Range
Dim LastCellRowNumber As Long
Workbooks("! ! Template for Scheduling DataV2.xlsm").Activate
Set WS = Worksheets("DATA")
With WS
Set LastCellA = .Cells(.Rows.Count, "A").End(xlUp)
'Set LastCellB = .Cells(.Rows.Count, "B").End(xlUp)
LastCellRowNumber = Application.WorksheetFunction.Max(LastCellA.Row)
End With
WS.Select
Dim myOlApp As Outlook.Application
Dim myItem As Outlook.AppointmentItem
'find last row with information in column
For finalcell = 2 To LastCellRowNumber
'For finalcell = 2 To LastCellRowNumber
Set LastCellB = Range("C" & finalcell)
If Len(LastCellB) > 0 Then LastCellB = UCase(LastCellB)
If Range("J" & finalcell).Value = "" And Range("K" & finalcell).Value <> "" Then GoTo 5
'If Sheets("DATA").Range("Q" & finalcell) = "Scheduled" Then GoTo 5
'If Sheets("DATA").Range("Q" & finalcell) = "Scheduled" Then finalcell = (finalcell + 1) Else
Range("B" & finalcell).Formula = "=IFERROR(HLOOKUP(C" & finalcell & ",HUBS,2,FALSE),)"
Range("B" & finalcell).Select
With Selection
.Copy
.PasteSpecial Paste:=xlPasteValues
End With
Range("U" & finalcell).Formula = "=VLOOKUP(O" & finalcell & ",'Email List'!A$1:B$400,2,FALSE)"
Range("U" & finalcell).Select
With Selection
.Copy
.PasteSpecial Paste:=xlPasteValues
'Range("Q" & finalcell).Value = "Scheduled"
'Range("J" & finalcell).Value = "Invitation Sent"
End With
Set myOlApp = GetObject(, "Outlook.Application")
Set myItem = myOlApp.CreateItem(olAppointmentItem)
'Dim objectfiller As String
'objectfiller = Sheets("DATA").Range
With myItem
.Subject = "CHG " & Sheets("DATA").Range("k" & finalcell) & " " & Sheets("DATA").Range("B" & finalcell) & " " & Sheets("DATA").Range("C" & finalcell) & " " & Sheets("DATA").Range("F" & finalcell) & " "
.Location = Sheets("DATA").Range("b" & finalcell) & " " & Range("C" & finalcell)
.Start = Sheets("DATA").Range("A" & finalcell)
''.Duration = Sheets("DATA").Range("d4")
.End = Sheets("DATA").Range("T" & finalcell)
''.ForwardAsVcal = sheeets("DATA").Range("t" & finalcell)
.Body = "Project Owner " & Sheets("DATA").Range("M" & finalcell) & Chr(10) & "CHG " & Sheets("DATA").Range("k" & finalcell) & Chr(10) & "TSK " & Sheets("DATA").Range("l" & finalcell) & Chr(10) & Sheets("DATA").Range("B" & finalcell) & Chr(10) & "Hub " & Sheets("DATA").Range("C" & finalcell) & Chr(10) & Sheets("DATA").Range("F" & finalcell) & " " & Chr(10) & "MOP: " & Sheets("DATA").Range("N" & finalcell)
.RequiredAttendees = Sheets("DATA").Range("u" & finalcell)
'' .Recipients = Sheets("DATA").Range("u" & finalcell)
.Send
.Save
Range("Q" & finalcell).Value = "Scheduled"
Range("J" & finalcell).Value = "Invitation Sent "
End With
5
Next finalcell
ActiveWorkbook.Save
' Sub Mail_Workbook_1()
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010.
' This example sends the last saved version of the Activeworkbook object .
ActiveWorkbook.SaveAs Filename:="Work Status Dated " & Format(Date, "MM.DD.YYYY ") & Format(Time, "hh.mm") & ".xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
'ActiveWorkbook.SaveAs Filename:="! ! Template for Scheduling DataV2.xlsm", FileFormat:=52, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
'Workbooks("! ! Template for Scheduling DataV2.xlsm").Activate
Dim this_thur
this_thur = Now() - Weekday(Now()) + 5 + (Weekday(Now()) > 5) * 7
If today = this_thur Then GoTo 10
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
' Change the mail address and subject in the macro before you run it.
With OutMail
.To = "stephen.pannunzio@gmail.com"
.CC = ""
.BCC = ""
.Subject = "Work Status Summary Report " & Now()
.Body = Chr(10) & "Report generated by Stephen Pannunzio." & Chr(10) & "Generated on " & Now() & Chr(10) & "Located P:\Eng\Network Planning\!2013 MOPS"
.Attachments.Add Workbooks("Work Status Dated " & Format(Date, "MM.DD.YYYY ") & Format(Time, "hh.mm") & ".xls").FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
10
ActiveWorkbook.SaveAs Filename:="! ! Template for Scheduling DataV2" & ".xlsm", FileFormat:=52, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
End Sub