Like expression cause performance problem

[SHIRLEY YEUNG]

Here is part of the codes. I want to use the statements to check if the email subject matches to any of the subjects saved in column K. It can execute without problem. However, email subject can vary from time to time, but still it should contains some key words unchanged. So I tried to use Like instead of = . But when I execute it hanged my Excel. Please give me some advice. Thanks!

Range("K2").Select
For Each A In Range(Selection, Selection.End(xlDown))
subjectVal = A.Value

If UCase(OSubject) = UCase(subjectVal) Then
ActiveCell.Offset(0, -7).Range("A1").Select
------------------------------------------------------
Range("K2").Select
For Each A In Range(Selection, Selection.End(xlDown))
subjectVal = A.Value

If UCase(OSubject) Like "*" & UCase(subjectVal) & "*" Then
ActiveCell.Offset(0, -7).Range("A1").Select

 

[AlphaFrog]

Replace this...

If UCase(OSubject) Like "*" & UCase(subjectVal) & "*" Then

With this...

If Instr(1, OSubject, subjectVal, 1) Then

This checks if subjectVal can be found within the string OSubject. It is not case sensitive.

 

[SHIRLEY YEUNG]

Hi AlphaFrog,

Thanks for your responose. But it also hanged even after I replaced with Instr.

Shirley

 

[AlphaFrog]

I know this...
If Instr(1, OSubject, subjectVal, 1) Then
...should work if both OSubject and subjectVal are text strings.

I don't know what OSubject is or how you defined it.

What is the error message when you debug it?

 

[SHIRLEY YEUNG]

Dim Oitem As outlook.MailItem
Dim OSubject As String
Dim subjectVal As String

OSubject = Oitem.Subject

The process will go through an email box and check each of the email subjects. If it matches the criteria on column K then the email and its attachment will be saved in a path. I have a status bar that tells me which email is being processed.

Application.StatusBar = "/!\ Emails scanning... Email : " & i & " of " & NbMess

I have placed 3 emails in the mailbox for testing. The first email fits the criteria while the others are not. When I ran the macro, using Like or Instr expression, it can saved down the first email & its attachment. But then status bar remained ' 1 of 3 ' and did not work on the next. There was no error message. I just went to the task manager to kill the procedure. Thanks!

 

[AlphaFrog]

The problem is probably not with the Like or Instr line.
I can't be more specific without seeing the entire macro.

It would be best if you surround your VBA code with code tags e.g.; [CODE]your VBA code here[/CODE]
It makes reading your VBA code much easier.
When you're in the forum editor, highlight your pasted VBA code and then click on the pound # icon.

 

[SHIRLEY YEUNG]

Here are the codes in a module. Please take a look. Thanks!

Dim FileName As String
Dim ns As outlook.Namespace
Dim inbox As outlook.MAPIFolder
Dim atmt As outlook.Attachment
Dim i As Integer, x As Integer, k As Integer, NbMess As Integer
 
Sub OutlookExtractorProcessus()
Application.Calculation = xlCalculationAutomatic
Application.EnableCancelKey = xlDisabled
Sheets("Menu").Select
ProcessorName = ActiveWorkbook.Name
Application.DisplayStatusBar = True
Application.StatusBar = "Ready"
Call Getmailattachements
Application.ScreenUpdating = True
Workbooks(ProcessorName).Save
 Application.StatusBar = "Ready"
 Application.EnableCancelKey = xlEnabled
End Sub
 
Sub Getmailattachements()
Dim i As Integer
Dim osender As String, TempOsender As String, Osign As String
Dim fs, f
Dim gs, g, s
Dim fsa
Dim ArchiveFolder As String, ArchiveNameTag As String
Dim Oitem As outlook.MailItem
Dim NbCaract As Integer, NbCaractNsender As Integer, NbCaractStesender As Integer
Dim OfileName As String, OextFile As String, OfilePath As String
Dim OfileDateRecept As Variant, ItemValue As Variant
Dim MailDateRecept As Date
Dim OSubject As String
Dim atmtCount As Integer
ProcessorName = ActiveWorkbook.Name
statusBarInitial = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.ScreenUpdating = False
ArchiveFolder = Workbooks(ProcessorName).Sheets("Menu").Cells(7, 5) & "\"
WorkFilePath = Workbooks(ProcessorName).Sheets("Menu").Cells(8, 5) & "\"
On Error GoTo Terminer:
Set ns = outlook.GetNamespace("MAPI")
 
Set inbox = ns.Folders("Mailbox - Shirley Yeung").Folders("zzzz")
On Error GoTo 0
x = 0
k = inbox.Items.Count
NbMess = k
If k = 0 Then
  'MsgBox "There are no messages in the selected Mailbox !", vbInformation, "Nothing Found"
  GoTo Terminer
End If
For i = 1 To k
  If k <= 0 Then
      GoTo Terminer
  End If
 
  Application.StatusBar = "/!\ Emails detachment running...    Email : " & i & "  of  " & NbMess
 
  On Error GoTo Terminer
  Set Oitem = inbox.Items(k)
  On Error GoTo 0
  osender = Oitem.SenderEmailAddress
  OSubject = Oitem.Subject
    'Remove forbidden characters from filename
    OSubject = Replace(OSubject, "\", " ")
    OSubject = Replace(OSubject, "/", " ")
    OSubject = Replace(OSubject, ">", " ")
    OSubject = Replace(OSubject, "<", " ")
    OSubject = Replace(OSubject, ",", " ")
    OSubject = Replace(OSubject, ";", " ")
    OSubject = Replace(OSubject, ":", " ")
    OSubject = Replace(OSubject, "?", " ")
    OSubject = Replace(OSubject, "*", " ")
    OSubject = Replace(OSubject, Chr(34), " ")
    OSubject = Left(OSubject, 120)
  MailDateRecept = Oitem.ReceivedTime
  lannee = Year(MailDateRecept)
  lemois = Month(MailDateRecept)
    If lemois < 10 Then lemois = "0" & lemois
  lejour = Day(MailDateRecept)
    If lejour < 10 Then lejour = "0" & lejour
  lheure = Hour(MailDateRecept)
    If lheure < 10 Then lheure = "0" & lheure
  lesminutes = Minute(MailDateRecept)
    If lesminutes < 10 Then lesminutes = "0" & lesminutes
  lsecond = Second(MailDateRecept)
    If lsecond < 10 Then lsecond = "0" & lsecond
 
  OfileDateRecept = "_" & lannee & lemois & lejour & "_" & lheure & "h" & lesminutes & "m"
 
  Osign = "@"
  NbCaract = Len(osender)
  NbCaractNsender = InStr([osender], [Osign])
  NbCaractStesender = (NbCaract - NbCaractNsender)
 
  TempOsender = Right(osender, NbCaractStesender)
  Workbooks(ProcessorName).Activate
  Sheets("XrefEmail").Select
  [A1].Select
  Range("K2").Select
 
 Dim subjectVal As String
 
  On Error Resume Next
  For Each A In Range(Selection, Selection.End(xlDown))
      subjectVal = A.Value
 
   If InStr(1, OSubject, subjectVal, 1) Then
    ActiveCell.Offset(0, -7).Range("A1").Select
 
    ArchiveNameTag = ActiveCell.Text
    OfilePath = ArchiveFolder & lannee & "-" & lemois & "\" & ArchiveNameTag & "\"
    'Go through attachments
    For Each atmt In Oitem.Attachments
      DoEvents
      OfileName = atmt.FileName
      OextFile = Right(OfileName, 4)
      If OextFile = ".csv" Then
        OextFile = ".txt"
      ElseIf OextFile = ".CSV" Then
        OextFile = ".txt"
      ElseIf OextFile = ".xlt" Then
        OextFile = ".xls"
      ElseIf OextFile = "xlsx" Then
        OextFile = ".xlsx"
      End If
      Set fsa = CreateObject("Scripting.FileSystemObject")
      If fsa.FileExists(WorkFilePath & ArchiveNameTag & OfileDateRecept & "_" & OfileName & OextFile) Then
        Randomize (1000)
        OfileName = OfileName & Rnd(1000)
      End If
      OfileName = OfileDateRecept & "_" & OfileName & OextFile
 
      atmt.SaveAsFile WorkFilePath & ArchiveNameTag & OfileName
      atmtCount = atmtCount + 1
    Next atmt
 
    'Check if archive folder does already exists
    Set gs = CreateObject("Scripting.FileSystemObject")
    Set g = gs.GetFolder(OfilePath)
    s = g.DateCreated
 
    If s > 1 Then
      'Save email in the relvant archive folder
      Oitem.SaveAs OfilePath & ArchiveNameTag & OfileDateRecept & lsecond & "s_" & OSubject & ".msg", olMSGUnicode
    Else
      Set g = gs.GetFolder(ArchiveFolder & lannee & "-" & lemois)
      s = g.DateCreated
      If Not s > 1 Then
        MkDir (ArchiveFolder & lannee & "-" & lemois)
        MkDir (ArchiveFolder & lannee & "-" & lemois & "\" & ArchiveNameTag)
      Else
        MkDir (ArchiveFolder & lannee & "-" & lemois & "\" & ArchiveNameTag)
      End If
      Oitem.SaveAs OfilePath & ArchiveNameTag & OfileDateRecept & lsecond & "s_" & OSubject & ".msg", olMSGUnicode
    End If
 
    ActiveCell.Offset(0, 1).FormulaR1C1 = osender
    ActiveCell.Offset(0, 2).FormulaR1C1 = OSubject
    ActiveCell.Offset(0, 3).FormulaR1C1 = "'" & lejour & "/" & lemois & "/" & lannee & " " & lheure & ":" & lesminutes
 
    'Deletes Email if its contains an attachment. Otherwise it keeps the Email in inbox and goes to the next email.
    If atmtCount >= 0 Then
      Oitem.Delete
      CountEmails = CountEmails + 1
    Else
      x = x + 1
    End If
 
  End If
 
  Next A
    x = x + 1
 
  OfileName = ""
  OextFile = ""
  OfilePath = ""
  ArchiveNameTag = ""
  TempOsender = ""
  OSubject = ""
  NbCaract = "0"
  NbCaractNsender = "0"
  NbCaractStesender = "0"
  OfileDateRecept = ""
  MailDateRecept = "0"
  atmtCount = 0
  g = "0"
  gs = "0"
  s = "0"
 
  k = inbox.Items.Count
  k = k - x
Next
Terminer:
Sheets("Menu").Select
Application.StatusBar = "Ready"
End Sub

 

[AlphaFrog]

Nothing wrong pops out. Hard to test without your data and configuration.

Try commenting out all the On Error lines and then run the macro to see where it hangs.

 

[SHIRLEY YEUNG]

Hi AlphaFrog,

If I use

 If UCase(subjectVal) Like "*" & UCase(OSubject) & "*" Then

instead of

 If UCase(OSubject) Like "*" & UCase(subjectVal) & "*" Then

The program can run without hanging. But OSubject is the orginal email subject & subjectVal is only the keywords for verifying the target email so in logic I cannot use the statement.

I still wonder why the second statement would grab email of which the subject does not match with the keyword and then hang the program. It seems that the second statement read subjectVal as empty so it matches all email subjects.

 

[Norie]

I'm guessing but the problem might be here.

Workbooks(ProcessorName).Activate
  Sheets("XrefEmail").Select
  [A1].Select
  Range("K2").Select

For Each A In Range(Selection, Selection.End(xlDown))

Using Selection/Select is not a good idea and neither is using xlDown.

In fact the xlDown might be, combined with the Selection, the real problem.

You could actually be looping through every single row of the spreadsheet, and you might not even be doing that on the right spreadsheet.

See if this works any better.

Set rng = Workbooks(ProcessorName).Sheets("XrefEmail").Range("K2")

For Each A In Range(rng, Workbooks(ProcessorName).Sheets("XrefEmail").Cells(Rows.Count, rng.Column).End(xlUp))

By the way, where is this code being run from?

If it's Excel is it in the workbook you are trying to work with?

The reason I ask is because instead of having to refer to the workbook as Workbooks(ProcessorName) throughout the code you might be able to create a reference to it.

To do that you could do something like this.

Set wb = ThisWorkbook

You could then use wb whenever you need to refer to the workbook.