Я новичок здесь и прошу прощения, если этот вопрос слишком прост для большинства здесь.Я использую Excel VBA, чтобы открыть конкретное электронное письмо, найти информацию в нужной мне таблице и отправить эту информацию обратно в электронную таблицу Excel.Мой код с тех пор сломался (работал ранее), потому что отправитель электронной почты решил форматировать свою электронную почту по-другому.Мне нужна помощь в пересмотре кода, чтобы найти нужную мне информацию.К вашему сведению, я не против переписать мой код полностью, я знаю, что есть более быстрый способ.
Если это не очень хорошо объясняется в коде, я просто ищу пример таблицы ниже в электронном письме ивосстановить эти 3 числа и поместить их в мою таблицу.Вот и все.
Пример таблицы:
OnHoldMerge / CancellationJob:
RXs Canceled 540
Orders Cancelled 459
Orders Merged 1035
Мой текущий код:
Option Explicit
Sub Import_OnHold_Merge_Job()
'''''''''''''''''''''''''''''''''''''''''''''''''''
' This function opens the On Hold/Merge Email from
' PSM, copies the three numbers on the OnHoldMerge/
' CancellationJob table, and pastes that data in the Trad
' workflow file on the provided tab.
'''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''
' CONSTANTS
'''''''''''''''''''''''''''''''''''''''''''''''''''
Const DestinationSheet = "Fairfax Aging" 'Sheet to output report
Const ReportRow = 19 'The row on Controls tab where this report is found
'''''''''''''''''''''''''''''''''''''''''''''''''''
' VARIABLES
'''''''''''''''''''''''''''''''''''''''''''''''''''
Dim lngRowCounter As Long
Dim lngColCounter As Long
Dim intChartRow As Integer
Dim lngLastRow As Long
Dim intLastCol As Integer
Dim lngDestinationRow As Long
Dim strFileName As String
Dim strTestFileName As String
Dim strErrorMessage As String
Dim wkbkReport As Workbook
'Outlook Variables
Dim olOutlook As Outlook.Application
Dim olEmail As Outlook.MailItem
Dim olBody As String
Dim olHTMLBody As String
Dim elements As Object
Dim element As Object
'Variables used to parse the html into usable data
Dim lngTableLocation As Long
Dim lngPrevTableStart As Long
Dim lngTableStart As Long
Dim lngTableEnd As Long
Dim strTableText As String
Dim lngRowStart As Long
Dim lngRowEnd As Long
Dim lngColStart As Long
Dim lngColEnd As Long
Dim lngFindLocation As Long
'index 1 = row #, index 2 = col #
Dim strCellText(1 To 17, 1 To 2) As String
'Variables used during removal of unwanted text
Dim lngRemoveStart As Long
Dim lngRemoveEnd As Long
'''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION
'''''''''''''''''''''''''''''''''''''''''''''''''''
'On Error GoTo ErrorHandler
Debug.Print ("Sub Import_OnHold_Merge_Job")
'Initialize variable
ThisWorkbook.Activate
Sheets("Controls").Select
Range("C" & ReportRow) = "Running" 'Set current Status
Range("N" & ReportRow) = Now 'Log start time
strFileName = Range("D" & ReportRow) 'Get file location/name
'Disables screen updating to improve speed
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Find destination area
Sheets(DestinationSheet).Select
lngLastRow = Find_Last_Row("A")
For lngRowCounter = 1 To lngLastRow
If Cells(lngRowCounter, 1).Value = "IBML" Then
lngDestinationRow = lngRowCounter
Exit For 'Row found exit the loop
End If
Next lngRowCounter
'Clear previous values
Range(Cells(lngDestinationRow + 3, 5), Cells(lngDestinationRow + 5, 5)).Value = ""
'Initialize outlook
Set olOutlook = CreateObject("Outlook.Application")
'Check if file exists/open file
On Error GoTo FileOpenError
Set olEmail = olOutlook.Session.OpenSharedItem(strFileName)
On Error GoTo ErrorHandler
olEmail.Display
'Safety Measure to prevent email from being sent to anyone during testing
olEmail.To = ""
olEmail.CC = ""
olEmail.BCC = ""
'Copy the body of the email
olHTMLBody = olEmail.HTMLBody
'Locate the current and previous tables to find the correct table tags
lngTableLocation = InStr(1, olHTMLBody, "OnHoldMerge/CancellationJob:")
lngPrevTableStart = InStr(1, olHTMLBody, "Job Name")
lngTableStart = InStr(lngPrevTableStart, olHTMLBody, "<table")
lngTableEnd = InStr(lngTableStart, olHTMLBody, "</table>") + 17
strTableText = VBA.Mid(olHTMLBody, lngTableStart, lngTableEnd - lngTableStart)
'htmlTestTable = strTableText
lngFindLocation = 1
'Identify Rows in table
For lngRowCounter = 1 To 17
'Identify Cells in row
For lngColCounter = 1 To 2
'Find the start of the inside string
lngFindLocation = InStr(lngFindLocation, strTableText, "<td")
lngColStart = lngFindLocation
'Find the end of the inside string
lngFindLocation = InStr(lngFindLocation, strTableText, "</td")
lngColEnd = lngFindLocation
'Store the inside string
strCellText(lngRowCounter, lngColCounter) = VBA.Mid(strTableText, lngColStart, lngColEnd - lngColStart)
Next lngColCounter
Next lngRowCounter
'Clean up the strings
For lngRowCounter = 1 To 17
For lngColCounter = 1 To 2
'Remove any remaining html tags
Do While InStr(1, strCellText(lngRowCounter, lngColCounter), "<") > 0
'Find tag start
lngRemoveStart = InStr(1, strCellText(lngRowCounter, lngColCounter), "<")
'Find tag end
lngRemoveEnd = InStr(1, strCellText(lngRowCounter, lngColCounter), ">") + 1
'Remove tag
strCellText(lngRowCounter, lngColCounter) = Replace(strCellText(lngRowCounter, lngColCounter), _
VBA.Mid(strCellText(lngRowCounter, lngColCounter), lngRemoveStart, lngRemoveEnd - lngRemoveStart), _
"")
Loop
'Remove any remaining html new lines
Do While InStr(1, strCellText(lngRowCounter, lngColCounter), " ") > 0
'Find new line start
lngRemoveStart = InStr(1, strCellText(lngRowCounter, lngColCounter), " ")
'Find new line end
lngRemoveEnd = lngRemoveStart + 6
strCellText(lngRowCounter, lngColCounter) = Replace(strCellText(lngRowCounter, lngColCounter), _
VBA.Mid(strCellText(lngRowCounter, lngColCounter), lngRemoveStart, lngRemoveEnd - lngRemoveStart), _
"")
Loop
'Trim any remaining blank space
strCellText(lngRowCounter, lngColCounter) = VBA.Trim(strCellText(lngRowCounter, lngColCounter))
Debug.Print ("Row " & lngRowCounter & " Col " & lngColCounter & ": " & strCellText(lngRowCounter, lngColCounter))
Next lngColCounter
Next lngRowCounter
'Empty variables that are no longer needed
olEmail.Close (olDiscard)
Set olEmail = Nothing
Set olOutlook = Nothing
ThisWorkbook.Activate
Sheets(DestinationSheet).Select
'Output Variables
Cells(lngDestinationRow + 3, 5).Value = strCellText(3, 2)
Cells(lngDestinationRow + 4, 5).Value = strCellText(4, 2)
Cells(lngDestinationRow + 5, 5).Value = strCellText(5, 2)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
EndProcessing:
Report_Complete_Processing _
ReportRow:=ReportRow, _
reportStatus:="Completed", _
reportWorkbook:=wkbkReport
'End sub, process complete
Exit Sub
FileOpenError:
strErrorMessage = "Unable to locate the stored email, please enter values manually."
ErrorHandler:
'Output Error data to debug window
Debug.Print ("ErrNum: " & Err.Number)
Debug.Print ("ErrMsg: " & Err.Description)
'If there was no error message provided then use a generic message.
If strErrorMessage = "" Then
strErrorMessage = "There was a problem processing the report."
End If
Debug.Print ("Custom ErrMsg: " & strErrorMessage)
Report_Complete_Processing _
ReportRow:=ReportRow, _
reportStatus:="Failed", _
reportWorkbook:=wkbkReport, _
reportMessage:=strErrorMessage
End Sub