Repost:Excel not active / loses focus.Pls help!

[michael.beckinsale]

Hi All,

There are 2 code routines pasted below and both work fine individually.



However if l call the 2nd routine from the 1st Excel seems to 'lose
focus' ie the active workbook name is greyed out and flashing. If l
activate Excel by placing and clicking the cursor anywhere in the Excel

environment the code continues without a problem.


I have tried combining the code but the same problem manifests itself.


This is my 1st foray into extracting data from Outlook and l am
wondering if it has something to do with security but that would not
explain why the code continues immediately on return to the Excel
environment. Alternatively i think l might need to 'grab' the Excel
application and activate it.


Please can somebody help me overcome this infuriating problem?


Sub ListUnsubscribed()
'Variables for the Outlook Object Library
Dim myOlApp As Outlook.Application
Dim mpfInbox As Outlook.MAPIFolder
Dim obj As Outlook.MailItem
'Other variables
Dim i As Integer
Dim r As Long
Dim r1 As Long
'Define the variables
Set myOlApp = CreateObject("Outlook.Application")
Set mpfInbox =
myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Unsub­scribers")

'Set calcualtion to manual for more speed
Application.Calculation = xlManual
'Find next empty row on list
Sheets("Removed").Activate
Range("A2").Activate
r = ActiveCell.End(xlDown).Row + 1
If r = 65536 Then
MsgBox ("You have reached the limit of 65536 Unsubscribers")
Exit Sub
End If
If r < 65536 Or r > 1 Then
r = r
Else
r = 2
End If
'Set 1st row for copy to TemporaryList
r1 = r
'Loop all items in the Inbox\Unsubscribers Folder
For i = 1 To mpfInbox.Items.Count
If mpfInbox.Items(i).Class = olMail Then
Set obj = mpfInbox.Items.Item(i)
If obj.Subject = "unsubscribe" Or obj.Subject = "RE:
unsubscribe" Then
With Sheets("Removed")
.Cells(r, 1).Value = obj.SenderEmailAddress
.Cells(r, 2).Value = obj.Subject
.Cells(r, 3).Value = obj.ReceivedTime
.Cells(r, 4).Value = Now
.Cells.Columns.AutoFit
End With
'Delete the email
'obj.Delete
r = r + 1
End If
End If
Next
'Copy to TemporaryList
Sheets("Removed").Range("A" & r1 & "" & r).Copy
Destination:=Sheets("TemporaryList").Range("A2")
End Sub


Sub Delete_Unsubscribers()
'Delete unsubscribers from 'Current' sheet
Dim delName As String
Application.ScreenUpdating = True
Sheets("TemporaryList").Activate
Range("A2").Activate
Do Until ActiveCell.Value = ""
Sheets("TemporaryList").Activate
delName = ActiveCell.Value
Sheets("Current").Activate
Range("A1").Activate
With Sheets("Current").Range("A:A")
Set c = .Find(delName, lookin:=xlValues,
SearchOrder:=xlByColumns, SearchDirection:=xlNext)
If c Is Nothing Then
MsgBox "Search Value was not found"
Else
c.EntireRow.Delete
End If
End With
Sheets("TemporaryList").Activate
ActiveCell.Offset(1, 0).Activate
Loop
MsgBox ("finished")
Sheets("TemporaryList").Activate
Range("A22").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
'Reset to auto
Application.Calculation = xlManual
End Sub


Regards


Michael beckinsale

 

[Guest]

Michael,

You might want to try changing "Application" to XLApp by doing the following:

Dim XLApp as Excel.Application
Dim MyWorkbook as Excel.workbook
Dim Removed as Excel.worksheet


Sub ListUnsubscribed()
'Variables for the Outlook Object Library
Dim myOlApp As Outlook.Application
Dim mpfInbox As Outlook.MAPIFolder
Dim obj As Outlook.MailItem
'Other variables
Dim i As Integer
Dim r As Long
Dim r1 As Long
'Define the variables
Set myOlApp = CreateObject("Outlook.Application")

Set XLApp = GetObject(,"Excel.Application")
Set MyWorkbook = XLapp.Workbooks("MyWorkBookName")
Set Removed = MyWorkBook.Sheets("Removed")