Я не люблю критиковать чей-то английский, когда я давно забыл маленький французский и русский, которые я когда-то знал. Я считаю, что «найден» должен быть «найден»; глагол «найти» - это один из многих неправильных глаголов. Я не знаю, что означает «общежитие».
Ваш код декодирует текст сообщения электронной почты, выбранного с помощью Проводника. Это означает, что пользователь должен выбрать адрес электронной почты перед запуском этого сообщения. Это письмо содержит строки, которые вы ожидаете найти в книге. Без понимания причины такого подхода я не могу дать никакого совета, но мне это кажется очень странным.
Вы не говорите, почему вы ищете в листе «SalesForm» или что вы будете делать, когда найдете значение для поиска. Я возвратил значение из столбца D строки, содержащей значение поиска. Вы можете заменить «D» буквой или цифрой для другого столбца. Если ваше требование более сложное, вам нужно будет предоставить объяснение того, что вы ищете.
Я предоставил функцию «GetValueFromExcel» и подпрограмму, чтобы показать, как ее использовать. Вы можете скопировать мою функцию и вызвать ее из своего кода или изучить, как работает мой код, и создать свою собственную версию.
У вас есть:
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
У меня есть:
Dim xlApp As New Excel.Application
Ключевое слово «New» и «Excel.Application» для идентификации объекта, который я хочу, означают, что мне не нужен оператор CreateObject. Я читал, что ваш метод несколько более эффективен, чем мой, но вы часто увидите этот другой подход.
У вас есть:
Dim objOL As Outlook.Application
Dim objItem As Object
Set objItem = objOL.ActiveExplorer.Selection(1)
Вы находитесь в Outlook, поэтому вам не нужно objOL. Это так же, как:
Dim objItem As Object
Set objItem = ActiveExplorer.Selection(1)
Используемый как есть, On Error Resume Next означает «не сообщайте мне ни о каких ошибках, потому что мне нравятся загадочные сбои. Пожалуйста, не используйте это утверждение, если вы не знаете, что оно вам нужно, и не знаете, как правильно его использовать.
У вас есть:
strFile = "C:\Users\User\Desktop\SMS.xlsx" 'Put your file path.
Set sourceWB = Workbooks.Open(strFile, , False, , , , , , , True)
у меня есть:
With xlApp
Set WbkSrc = .Workbooks.Open(FileName:=Environ("UserProfile") & "\Desktop\SMS.xlsx")
End With
Environ("UserProfile") возвращает «C: \ Users \ xxxx», где «xxxx» - текущий пользователь. Если вы поделитесь этим макросом с коллегой, макрос адаптируется к новому пользователю без каких-либо изменений.
Я включил путь и имя файла в вызов Workbooks.Open, чтобы показать, что это возможно.
Вы указали параметры для книг. Откройте их по позиции. Я сделаю это, когда станет очевидно, что это за параметры, но мне не нравится считать запятые, чтобы понять, что означают Ложь и Истина. FileName:= проясняет, что это за параметр. Похоже, вы не хотите вносить изменения в эту книгу, поэтому я не вижу значения ReadOnly:=False. Я не верю, что Editable:=True имеет отношение.
sourceWB.Activate не обязательно.
Мой код указан ниже. Скопируйте его в модуль в вашей установке Outlook и опробуйте его, прежде чем решить, как добавить его в свою программу. Чтобы проверить мой код, я создал на своем рабочем столе книгу с именем «SMS.xlsx», поместил поисковые значения, такие как «Aaaaa», в столбец C и поместил возвращаемые значения в столбец D.
Макрос «GetValueFromExcel» выполняет поиск указанного столбца поиска в столбце C указанной рабочей таблицы. Возвращает значение из столбца D, если искомое значение найдено, и пустую строку, если искомое значение не найдено.
Макрос «TestGetValueFromExcel» демонстрирует, как использовать «GetValueFromExcel». Вам нужно будет заменить SearchValues = VBA.Array("Aaaaa", "Bbbbb", "Fffff", "Hhhhh"). Значения «Aaaaa», «Bbbbb» и «Fffff» отображаются в моем столбце C. Значение «Fffff» не отображается в моем столбце C. Замените мои значения значениями из вашего столбца C.
Option Explicit
Sub TestGetValueFromExcel()
Dim ReturnedValue As String
Dim SearchValue As Variant
Dim SearchValues As Variant
Dim WbkSrc As Workbook
Dim WshtSrc As Worksheet
Dim xlApp As New Excel.Application
SearchValues = VBA.Array("Aaaaa", "Bbbbb", "Fffff", "Hhhhh")
With xlApp
.Visible = True ' Slows execution but helpful during debugging
.EnableEvents = False
Set WbkSrc = .Workbooks.Open(FileName:=Environ("UserProfile") & "\Desktop\SMS.xlsx")
End With
With WbkSrc
Set WshtSrc = .Worksheets("SalesForm")
End With
For Each SearchValue In SearchValues
ReturnedValue = GetValueFromExcel(WshtSrc, CStr(SearchValue))
If ReturnedValue = "" Then
Debug.Print """" & SearchValue & """ not found"
Else
Debug.Print """" & SearchValue & """ returned """ & ReturnedValue & """"
End If
Next
WbkSrc.Close SaveChanges:=False
Set WbkSrc = Nothing
With xlApp
.EnableEvents = False
.Quit
End With
Set xlApp = Nothing
End Sub
Обновление: диагностическая версия GetValueFromExcel плюс DsplInHex, PadL и PadR
Function GetValueFromExcel(ByRef Wsht As Worksheet, ByVal SearchValue As String) As String
Dim Rng As Range
Dim RowCrnt As Long
Dim RowLast As Long
With Wsht
Set Rng = .Columns("B").Find(What:=SearchValue, After:=.Range("B1"), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, _
SearchFormat:=False)
If Rng Is Nothing Then
' SearchValue not found
Debug.Print "SearchValue not found"
RowLast = .Cells(.Rows.Count, "B").End(xlUp).Row
For RowCrnt = 2 To RowLast
Debug.Print Wsht.Name & ".Cells(" & RowCrnt & ",B):"
Call DsplInHex(.Cells(RowCrnt, "B").Value)
Next
Debug.Print "SearchValue:"
Call DsplInHex(SearchValue)
GetValueFromExcel = ""
Else
' Return value in column D of row containing SearchValue
GetValueFromExcel = .Cells(Rng.Row, "C")
End If
End With
End Function
Public Sub DsplInHex(Stg As String)
' Display Stg in text and hex-digit format.
' 19Apr16 Latest date on which it might have been coded.
' Pre- / Hex-digit format only as single row with space between
' 17Aug17 \ each character and no padding of short hex values.
' 17Aug17 Amended to display text value of characters as well as hex values
' and for fixed width display with position within string upto 999.
Dim ChrGt255 As Boolean
Dim ChrLng As Long
Dim ChrStr As String
Dim LineHex As String
Dim LineTxt As String
Dim PadLen As Long
Dim Pos As Long
' Check for (1) all characters at most two hex-digits or (2) at least
' one character being more than two hex-digits
ChrGt255 = False
For Pos = 1 To Len(Stg)
If AscW(Mid(Stg, Pos, 1)) > 255 Then
ChrGt255 = True
End If
Next
If ChrGt255 Then
' Need upto four hex-digits per character
PadLen = 4
Else
' Need at most two hex-digits per character
PadLen = 2
End If
LineHex = " |"
LineTxt = "---|"
For Pos = 0 To 9
LineHex = LineHex & " " & PadL(Chr$(Asc("0") + Pos), PadLen)
Next
LineTxt = PadR(LineTxt, Len(LineHex), "-")
For Pos = 0 To Len(Stg) - 1
If Pos Mod 10 = 0 Then
Debug.Print LineHex ' Output heading or previous line
Debug.Print LineTxt
' Initialise next line
LineHex = PadL(Format(Pos, "###"), 3, "0") & "|" ' Position of first character on line
LineTxt = " |"
End If
ChrStr = Mid(Stg, Pos + 1, 1)
ChrLng = AscW(ChrStr)
If ChrLng < 0 Then
' Character is &H8000& or above and the top bit is negative
ChrLng = ChrLng + 65536
End If
If ChrLng < 32 Or (ChrLng >= 127 And ChrLng < 160) Then
' Control character (non-display)
ChrStr = "nd"
End If
LineHex = LineHex & " " & PadL(Hex(ChrLng), PadLen)
LineTxt = LineTxt & " " & PadL(ChrStr, PadLen)
Next
Debug.Print LineHex ' Output final line
Debug.Print LineTxt
End Sub
Public Function PadL(ByVal Str As String, ByVal PadLen As Long, _
Optional ByVal PadChr As String = " ") As String
' Pad Str with leading PadChr to give a total length of PadLen
' If the length of Str exceeds PadLen, Str will not be truncated
' Sep15 Coded
' 20Dec15 Added code so overlength strings are not truncated
' 10Jun16 Added PadChr so could pad with characters other than space
If Len(Str) >= PadLen Then
' Do not truncate over length strings
PadL = Str
Else
PadL = Right$(String(PadLen, PadChr) & Str, PadLen)
End If
End Function
Public Function PadR(ByVal Str As String, ByVal PadLen As Long, _
Optional ByVal PadChr As String = " ") As String
' Pad Str with trailing PadChr to give a total length of PadLen
' If the length of Str exceeds PadLen, Str will not be truncated
' Nov15 Coded
' 15Sep16 Added PadChr so could pad with characters other than space
If Len(Str) >= PadLen Then
' Do not truncate over length strings
PadR = Str
Else
PadR = Left$(Str & String(PadLen, PadChr), PadLen)
End If
End Function