Я в основном наполовину завершил свой код VBA для проекта, но я чувствую, что его нужно улучшить или оптимизировать. Могу ли я попросить помощи о том, что изменить / изменить / удалить / оптимизировать?
Я относительно новичок в VBA.
Мой код следующий:
Function WorksheetExists(sheet_name As String, Optional wb As Workbook) As Boolean
Dim ws As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set ws = wb.Sheets(sheet_name)
On Error GoTo 0
WorksheetExists = Not ws Is Nothing
End Function
Sub GetEmailDetailsInWorksheets()
Dim outlook_app As Outlook.Application
Dim namespace As Outlook.namespace
Dim folders_collection As New Collection
Dim folder As Outlook.MAPIFolder
Dim sub_folder As Outlook.MAPIFolder
Dim obj_mail As Outlook.MailItem
Dim obj_item
Dim row_number As Long
Dim msgs_found_counter As Long
Dim working_ws As Worksheet
Dim active_cell_value As String
Set outlook_app = New Outlook.Application
Set namespace = outlook_app.GetNamespace("MAPI")
Set working_ws = Sheets("Working")
active_cell_value = ActiveCell.Value
For Each folder In namespace.Folders
For Each sub_folder In folder.Folders
folders_collection.Add sub_folder
Next sub_folder
Next
row_number = 4
msgs_found_counter = 0
If ActiveSheet.Name = "Working" Then
If active_cell_value <> "" Then
If WorksheetExists(active_cell_value) = False Then
Sheets.Add(After:=Sheets("Working")).Name = active_cell_value
Cells(row_number - 1, 1) = "Entry ID"
Cells(row_number - 1, 2) = "Folder Path"
Cells(row_number - 1, 3) = "Received Time"
Cells(row_number - 1, 4) = "Sender"
Cells(row_number - 1, 5) = "Recipients"
Cells(row_number - 1, 6) = "Email Subject"
MsgBox "PRESS OK TO CONTINUE."
Do While folders_collection.Count > 0
Set folder = folders_collection(1) 'Get next folder to process
folders_collection.Remove 1 'Remove that folder from the collection
Application.StatusBar = folder.FolderPath
For Each obj_item In folder.Items
If obj_item.Class = olMail And InStr(1, obj_item.Subject, active_cell_value, vbTextCompare) > 0 Then
Set obj_mail = obj_item
Application.StatusBar = row_number & " - " & folder.FolderPath
On Error Resume Next
Cells(row_number, 1) = obj_mail.EntryID
Cells(row_number, 2) = folder.FolderPath
Cells(row_number, 3) = obj_mail.ReceivedTime
Cells(row_number, 4) = obj_mail.Sender
Cells(row_number, 5) = obj_mail.To
Cells(row_number, 6) = obj_mail.Subject
On Error GoTo 0
row_number = row_number + 1
msgs_found_counter = msgs_found_counter + 1
End If
Next obj_item
'Check for subfolders
For Each sub_folder In folder.Folders
folders_collection.Add sub_folder, before:=1
Next
Loop
MsgBox msgs_found_counter & " message/s found for """ & active_cell_value & """"
Range("A4").Select
Else
MsgBox "A sheet matching the selected cell already exists. Redirecting you now..."
Worksheets(active_cell_value).Activate
End If
Else
MsgBox "Active cell is blank."
End If
Else
MsgBox "You are in the wrong worksheet. Try again."
End If
Application.StatusBar = False
End Sub
Любое руководство будет высоко ценится. Мне нужна помощь с вложенными ifs или упрощениями любых строк кода. Спасибо.