Auto Running a macro on open

[Jamie]

Hi There

I have put together the following macro that searches my inbox for specific
subject line content and attachments. It then saves all these attachments to
a specific folder, opens each attachment, copies and pastes certain details
into th espreadsheet that I run the macro from and then closes.

This macro works fine when I run it through tools>macro>run macro etc but
what I really need is for it to run automatically when the sheet is opened.
Can anyone tell me how to do this?


Sub SaveAttachments()

Windows("EIS Job Log test.xls").Activate
Range("B2").Select



Dim olApp As Outlook.Application
Dim olNs As NameSpace
Dim Fldr As MAPIFolder
Dim MoveToFldr As MAPIFolder
Dim olMi As MailItem
Dim olAtt As Attachment
Dim MyPath As String
Dim i As Long

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set MoveToFldr = Fldr.Folders("eisreq")
MyPath = "I:\EIS\Forms\EIS Requests\"
dattim = Format(Date, "yyyymmdd") & " " & "Time-" & Format(Time, "hhmmss")


For i = Fldr.Items.Count To 1 Step -1
Range("A1").Select


rowlength = Selection.CurrentRegion.Rows.Count
Set olMi = Fldr.Items(i)
If InStr(1, olMi.Subject, "EIS") > 0 Then
For Each olAtt In olMi.Attachments
If olAtt.Filename = "EIS Request.xls" Then
olAtt.SaveAsFile MyPath & Fldr.Items.Count & " " &
olMi.SenderName & " " & "Date-" & dattim & ".xls"
open1 = MyPath & Fldr.Items.Count & " " &
olMi.SenderName & " " & "Date-" & dattim & ".xls"
filenm = Fldr.Items.Count & " " & olMi.SenderName & "
" & "Date-" & dattim & ".xls"
End If

Next olAtt
olMi.Save
olMi.Move MoveToFldr
Workbooks.Open Filename:=open1

'copies and pastes date received
Range("B5").Select
Selection.Copy
Windows("EIS Job Log test.xls").Activate
Range("A1").Select
For x = 1 To rowlength
If ActiveCell.Cells <> "" Then
Cells(ActiveCell.Row + 1, 1).Select
End If
Next x
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

'copies and pastes Requester
Windows(filenm).Activate
Range("B13").Activate
Selection.Copy
Windows("EIS Job Log test.xls").Activate
Range("B1").Select
For x = 1 To rowlength
If ActiveCell.Cells <> "" Then
Cells(ActiveCell.Row + 1, 2).Select
End If
Next x
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

'copies and pastes Eis Staff Member
Windows(filenm).Activate
Range("B15").Activate
Selection.Copy
Windows("EIS Job Log test.xls").Activate
Range("C1").Select
For x = 1 To rowlength
If ActiveCell.Cells <> "" Then
Cells(ActiveCell.Row + 1, 3).Select
End If
Next x
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

'copies and pastes Description
Windows(filenm).Activate
Range("A20").Activate
Selection.Copy
Windows("EIS Job Log test.xls").Activate
Range("D1").Select
For x = 1 To rowlength
If ActiveCell.Cells <> "" Then
Cells(ActiveCell.Row + 1, 4).Select
End If
Next x
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

'copies and pastes Deadline
Windows(filenm).Activate
Range("B17").Activate
Selection.Copy
Windows("EIS Job Log test.xls").Activate
Range("D1").Select
For x = 1 To rowlength
If ActiveCell.Cells <> "" Then
Cells(ActiveCell.Row + 1, 5).Select
End If
Next x
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

'copies and pastes filename
Range("E1").Select
For x = 1 To rowlength
If ActiveCell.Cells <> "" Then
Cells(ActiveCell.Row + 1, 6).Select
End If
Next x
ActiveCell = filenm

Windows(filenm).Activate
ActiveWorkbook.Close False

End If
Next i

Set olAtt = Nothing
Set olMi = Nothing
Set Fldr = Nothing
Set MoveToFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing

End Sub

 

[Vasant Nanavati]

Sub Workbook_Open
'your code here
End Sub

Paste this into the code module associated with the ThisWorkbook object.

 

[Bob Phillips]

You need worksheet evnts. Take a look at
http://www.cpearson.com/excel/events.htm