VBA count emails module! - vba

This is a follow-up question of one which I posted yesterday. I feel I am getting quite close to creating a module in VBA that will count the number of e-mails sent on a particular day of the week. For the moment the day chosen is Monday.
However, the code is not yet working, and Outlook refuses to see the particular module.
I am sure there are a couple of errors in it. If someone could point these out, I would greatly appreciate it.
I also think that such code could be useful for others for future reference as the code for this kind of module does not seem to be readily available on the internet (I've looked!) and yet forms a type of search parameter that many will find useful!
Sub Count2(Optional dteDate As Date)
Dim objOutlook As Object, objnSpace As Object, objFolder As Object
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = objnSpace.Folders("My Personal Emails").Folders("spam")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
Select Case Weekday(dteDate)
Case vbMonday
dteDate = Date
End Select
For Each MapiItem In MapiFolderInbox.Messages
If MapiItem.TimeReceived = Date Then
Count = Count + 1
Next MapiItem
End If
EmailCount = objFolder.Items.Count
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
MsgBox "Number of emails in the folder: " _
& EmailCount, , "Number of spam messages sent on a Monday: " & Count
End Sub

Whilst debugging drop the on error resume next.
It hides the errors. You can put it back later if you have to.
It's not a great idea to ignore errors, better to handle the errors explicitly.
One thing that struck me:
For Each MapiItem In MapiFolderInbox.Messages
If MapiItem.TimeReceived = Date Then
Count = Count + 1
Next MapiItem
End If
Should be
For Each MapiItem In MapiFolderInbox.Messages
If MapiItem.TimeReceived = Date Then
Count = Count + 1
End If
Next MapiItem
Other than that it looks OK to me.

i think time received is more of a timestamp where in addition to date it would have time too. you should probably use it like this;
For Each MapiItem In MapiFolderInbox.Messages
If MapiItem.TimeReceived > YTS And MapiItem.TimeReceived < TTS Then
Count = Count + 1
End If
Next MapiItem
where YTS and TTS are timestamps where it would have yesterday's timestamp and today timestamp
for eg 01:06:2011:23:59:00 and 02:06:2011:23:59:00
you should comfirm this by debuging your code. hope this helps.

Outlook only sees the module when the parameters are left empty... as opposed to containing (Optional dteDate As Date).
Other than that, following the suggestion by Johan, the Module runs, but only ever has Count = 1. That is, that the result of emails received on a Monday is always 1 regardless of the input.
I also tried adbanginwar's suggestion, but in this case a compile error of 'Expected: Then or GoTo' is displayed.

Related

Is row not empty then go to next row to paste data based on current date in Column

I am new to VBA, so trying to to execute this code, I am able to run the code in the row where I want it but i want to run the code for next 2 row as well but don't know how to apply logic to go next available row. As I want to copy data for 3 times for the same date. The code as follows which generate upon button click.
Adding additional info: thanks everyone for your input and your time, much appreciated for your help.
This is great, I learn new things however, as I am updating data reading three times a day so, I want to copy my reading data from the row where I am updating three times a day so for tracking purpose I want to copy reading data the rows below as per data.
On click reading data should copy to the row for the morning, afternoon and evening reading as you can see from sample image herewith sample format
Excel Format
I hope I am able to explain my query as I am not a tech person but trying my best.
Thanking you for your help.
Private Sub CommandButton1_Click()
Dim Rg As Range
Set Rg = Me.UsedRange.Columns(1).Find(Application.Text(Date, [A16].NumberFormat), [A17], xlValues)
If Rg Is Nothing Then MsgBox "Today's Date Not Found. Please check the 'Date Received'" Else Rg(1, 2).Resize(, 24).Value2 = [B16:W16].Value2: Set Rg = Nothing
' If Rg Is Nothing Then MsgBox "Today's Date Not Found. Please check the 'Date Received'" Else Rg(2, 2).Resize(, 24).Value2 = [B16:W16].Value2: Set Rg = Nothing
' If Rg Is Nothing Then MsgBox "Today's Date Not Found. Please check the 'Date Received'" Else Rg(3, 2).Resize(, 24).Value2 = [B16:W16].Value2: Set Rg = Nothing
End Sub
Try this: you can use Resize() to fill 3 rows instead of only one.
Private Sub CommandButton1_Click()
Dim Rg As Range, copyRange As Range
Set Rg = Nothing
Set Rg = Me.UsedRange.Columns(1).Find(Application.Text(Date, [A16].NumberFormat), [A17], xlValues)
If Rg Is Nothing Then
MsgBox "Today's Date Not Found. Please check the 'Date Received'"
Else
Set copyRange = [B16:W16]
Rg.Offset(0, 1).Resize(3, copyRange.Columns.Count).Value2 = [B16:W16].Value2
End If
End Sub

How find relationships with lags and leas in Microsoft project with vba?

I have tried to find leads with the Microsoft project VBA but I was not successful I tried the following code but it gives me 2280 leads while the total number of relations in my schedule is 2156
Sub NumberofLeads()
Dim Lead As Integer
Dim t As Task
Dim td As TaskDependency
Lead = 0
For Each t In ActiveProject.Tasks
If Not t Is Nothing Then
For Each td In t.TaskDependencies 'looping in all the relations of a task
If td.Lag < 0 Then
Lead = Lead + 1
End If
Next
End If
Next t
MsgBox Lead & " Leads exist."
End Sub
Each task dependency consists of two tasks so looping through the tasks and then through all of each task's dependencies will encounter each dependency twice. The best way to handle this is to only look at the dependencies where the task is the predecessor (or successor, just pick one), by checking the From (or To) object's Unique ID and compare it to the current task:
Sub NumberofLeads()
Dim Lead As Integer
Dim t As Task
Dim td As TaskDependency
Lead = 0
For Each t In ActiveProject.Tasks
If Not t Is Nothing Then
For Each td In t.TaskDependencies
If td.From.UniqueID = t.UniqueID And td.Lag < 0 Then
Lead = Lead + 1
End If
Next
End If
Next t
MsgBox Lead & " Leads exist."
End Sub
Note: In case dividing by two seems easier than this solution, consider the case of external links. In that case the dependency will only be encountered once (the second task is not in the ActiveProject.Tasks collection) so dividing by two would yield the wrong answer.

Excel Tables VBA: Trying to select rows based on column value

I am a beginner. I have been trying to teach myself VBA and researching this question for two weeks, including reviewing all the relevant answers on this forum. I give up!
I am trying to loop through the rows of a table to select a table row based on the content of one of the row's cells (naming a particular column). I want to use the name of the table column. But something is wrong with my "If ... Then" statement. I get errors with every attempt. Right now I get a compile error "Expected Then or Go To," with the period before Value highlighted. But I have a feeling that if I fixed that error there would be another one right behind it. What am I getting wrong, besides trying to learn this on my own? ;>)
Thanks in advance!
Sub CommandButton1_Click()
Dim tbl As ListObject
Dim x As Long
Set tbl = ActiveSheet.ListObjects("Table1")
For x = 1 To tbl.Range.Rows.Count
If (Range("Table1[Status]")).Value = "Completed"
'I can't seem to find the right statement to put between If and .Value!
Rows(x).Select
End If
Next x
End Sub
Change If (Range("Table1[Status]")).Value = "Completed" to If (Range("Table1[Status]").Value) = "Completed" Then. Your .Value just needed to be put in the brackets. I would also highly suggest looking into the Rubberduck add-in for VBA. It has an Auto Indenter so your code always looks in order.
Sub CommandButton1_Click()
Dim tbl As ListObject
Dim x As Long
Dim myRange As Range
Set tbl = ActiveSheet.ListObjects("Table1")
For x = 1 To tbl.Range.Rows.Count
If tbl.DataBodyRange(x, Range("Table1[Status]").Column) = "Completed" Then
If myRange Is Nothing Then
Set myRange = tbl.ListRows(x).Range
Else
Set myRange = Union(myRange, tbl.ListRows(x).Range)
End If
End If
Next x
myRange.Select
End Sub

VBA Excel to Outlook (2010) - Creating Appointments from Date column with Unique dates only

Info: MS Office 2010
Problem(s) Multiple Outlook Profiles & Multiple Calendars & Same date repeated - I want unique only
From: Excel 2010
To: Outlook 2010
Question:
I want to create a VBA that will run from Excel to Outlook. I want to create appointments (tasks if it's proven to be far more suitable) based on a date column in my sheet.
The core issues are:
+ I have 3 different profiles, I only want the appointments/tasks showing in 1 profile (Admin).
+ I have different calendars, I would prefer the appointment to be in the default.
+ I want to add categories to my appointment/task
+ I have 10,000 rows of data, the dates repeat (a lot), I want only unique dates.
+ I do not want to have prior dates creating appointments/tasks (if possible).
I run 2 reports:
1st Tuesday of the month, pulls in all the sales data from previous months.
4 days before EOM I run the report a 2nd time looking for late payments, declines or refunds, as well as distributor payouts.
The appointments/tasks are to be set to match the dates in excel, or to save some column space I would be happy to have it written in to the VBA code to set the appointments:
1st Tuesday Month
4 days before EOM
I have got some great starter code, but because mine has a lot of data that needs to be filtered (unique dates only, and current to future dates preferred), I'm not sure what I need amended in my code to make it suitable for my setup.
Ref:
http://www.ozgrid.com/forum/showthread.php?t=18157&p=92262#post92262
http://www.vbaexpress.com/forum/showthread.php?25423-Solved-Excel-generate-calendar-appointments-in-Outlook&s=da1942ccfb8b85e3e7eb74ac4c95ed7d&p=177521&viewfull=1#post177521
My current code
Saved/Created in: Macro enabled spreadsheet, Modules (General, not under the sheet name), Tools/References/Microsoft Office 14.0 Object Library [Checked].
Sub StoreReminders()
Dim appOL As Object
Dim objReminder As Object
Set appOL = GetObject(, "Outlook.application")
Set objReminder = appOL.CreateItem(1) ' olAppointmentItem
Set ws1 = Worksheets("sql all 20131228")
objReminder.Start = ws1.Range("a1") & "10:30"
objReminder.Duration = "05:00"
objReminder.Subject = "EOM Reports #1"
objReminder.ReminderMinutesBeforeStart = 30
objReminder.ReminderSet = True
objReminder.Categories = "Acc - 1st Report"
'Becomes: "Acc - EOM Final" when 2nd appointment runs'
objReminder.BusyStatus = olBusy
objReminder.Save
End Sub
I am getting an error with some of this, starting with: Set appOL = GetObject(, "Outlook.application")
Any help would be great, I'm cutting & paste code together and I just can't get past the errors.
Thanks in advance :)
UPDATE
I received the following error when I used new code:
Compile Error: User-Defined type not defined
Sub SetAppt()
Dim olApp As Outlook.Application
Dim olApt As AppointmentItem
Dim MySheet As Worksheet
Set MySheet = Worksheets("sql all 20131228")
Set olApp = New Outlook.Application
Set olApt = olApp.CreateItem(olAppointmentItem)
With olApt
.Start = ws1.Range("n7") + TimeValue("10:30")
'Time is set to 10:30AM on the date of the reminder'
.Duration = "05:00"
.Subject = "EOM Reports #1"
.Location = "Office"
.Body = "Start of Month, EOM Reports"
.BusyStatus = olBusy
.ReminderMinutesBeforeStart = 60
.Categories = "Acc - 1st Report"
'Becomes: "Acc - EOM Final" when 2nd appointment runs'
.ReminderSet = True
.Save
End With
Set olApt = Nothing
Set olApp = Nothing
End Sub
So, still at square one not even basic code is working, so not sure how to include the advanced (Outlook User Profile, Unique only dates etc).
You need to add the proper Reference to the Outlook VBA module.
Go to Tools-->References and choose "Microsoft Outlook vXX Library"
That should fix the problem.

VBA deleting name throws object required

I just want to delete a few names that get created every time a querytable gets created. They are all in 3 sheets starting with 0048,0114,0715, so I would just delete all names that start with any of them. However, I get the rejection "object required" in the if clause when I use rName.Delete. Without this, the code runs fine and prints all the names. Also, if I do range(rName).delete it would delete the ranges in the workbook (not what I want, though).
Sub delNames()
Dim strStartString(0 To 2) As String
strStartString(0) = "'0048'!mta"
strStartString(1) = "'0114'!mta"
strStartString(2) = "'0715!'mta"
For Each rName In ActiveWorkbook.Names
For Each ss In strStartString
If rName.Name Like ss & "*" Then
Debug.Print rName.Name
rName.Delete
End If
Next ss
Next rName
End Sub
Any idea what I am doing wrong here?
Posting Tim's comment as solution
Modifying a collection while looping through it can cause problems. Try using a for next loop counting back through the names in reverse - For x = ActiveWorkbook.Names.Count to 1 Step -1 : ActiveWorkbook.Names(x).Delete – Tim Williams 49 mins ago