Возьмите части темы из электронного письма и введите их в таблицу Excel
Здравствуйте, ниже я включил текущий сценарий vba для запуска через файл, содержащий несколько электронных писем с определенными именами файлов, которые соответствуют изменениям адресов, обсуждаемым в электронных письмах. Я хочу взять текст, относящийся к изменению адреса, из каждого из этих имен файлов и ввести новый и старый адрес в таблицу Excel. Все электронные письма в этой папке делятся на 4 категории, в зависимости от формата их заголовков. Ниже приведены примеры всех четырех:
- «Распространение смены адреса - 14–12 Квин-стрит»
- «Циркуляция смены адреса - с 4 на 2 King Street»
- «Распространение смены адреса - от южной улицы 40 до главной авеню 1»
- «Циркуляция смены адреса - с 4-х дверной улицы на 2-ю десятую».
Как вы можете видеть, все они начинаются с одной и той же строки «Распространение смены адреса», однако у меня возникли проблемы с получением сценария, который может адаптироваться ко всем этим различным сценариям. Ниже я включил текущую версию сценария. Если у кого-то есть предложения или улучшения, которые были бы очень полезны, спасибо.
Dim StrFile As String
'Change this to the directory containing all Address Change Circulation emails
'This will Pull in a list and, to the best of its ability make two columns that hold the data for
'the old and the new address
StrFile = Dir(Range("AddressChangeFolderPath").Value)
Dim Names() As String
Dim StrName
Do While Len(StrFile) > 0
CheckVal = InStr(1, StrFile, "Address Change Circulation -", vbTextCompare) + _
InStr(1, StrFile, "Address Change Circulation from ", vbTextCompare)
If CheckVal <> 1 Then 'if the email does not fit the standard, just place it in the cell and
'move on to the next entry
Selection.Value = StrFile
Selection.Interior.Color = RGB(255, 255, 0) 'highlight the cell
Selection.Offset(1, 0).Select
Else
StrName = Right(StrFile, Len(StrFile) - 29) 'trim to the correct size - probably not the
'best way to do this but it works
If Left(StrName, 4) = "from" Then
StrName = Right(StrName, Len(StrName) - 5)
ElseIf Left(StrName, 2) = "om" Then
StrName = Right(StrName, Len(StrName) - 3)
End If
StrName = Left(StrName, Len(StrName) - 4)
Changes = Split(StrName, " and ")
For Each Change In Changes
Names = Split(Change, " to ")
If Len(Names(0)) < 5 Then
Selection.Value = Names(0) & Right(Names(1), Len(Names(1)) - Len(Names(0)))
Else
Selection.Value = Names(0)
End If
If UBound(Names) >= 1 Then 'this is a zero indexed array, checking greater than or
'equal to 1 will check if there are two or more entries
Selection.Offset(0, 1).Value = Names(1) ' in the event that there is no " to " in
'the file name and it hasn't been handeled already
End If
Selection.Offset(1, 0).Select 'select the next cell to accept the next entry
Next
End If
loop
Да, сценарий в настоящее время работает для первых двух перечисленных мной случаев, но не для последних двух случаев. Проблема, с которой я столкнулся, заключается в том, чтобы учесть последние два случая (в настоящее время сценарий учитывает два других). Еще одна вещь, которая является скорее вопросом, чем проблемой, заключается в том, что мне интересно, есть ли лучшие методы или функции для анализа данных из имен файлов? Этот текущий метод в основном представляет собой большое количество операторов if, заключенных в цикл while. Если бы существовал другой способ, который не полагался бы на единообразие имени файла и использование функций right () или left, я был бы открыт для его использования.
Ответы 1
Судя по вашим примерам, это, наверное, разумный подход. С этим легче справиться, если вы разделите парсинг на отдельный метод.
Просто проанализируйте тексты из диапазона на листе:
Sub Process()
Dim c As Range, op As String, np As String
For Each c In Range("A1:A6").Cells
ParseAddresses c.Value, op, np '<< passing np/op by reference...
c.Offset(0, 1).Value = op
c.Offset(0, 2).Value = np
Next c
End Sub
'Parse two addresses from "t" into "op" and "np"
Sub ParseAddresses(ByVal t, ByRef op As String, ByRef np As String)
Dim arr
op = "": np = ""
t = Trim(t)
If t Like "Address Change Circulation -*to*" Then
t = Replace(t, "Address Change Circulation -", "")
t = Replace(t, "from", "")
arr = Split(t, "to")
op = Trim(arr(0))
np = Trim(arr(1))
' "from" part is just a number: replace number in "to" part
If IsNumeric(op) Then
arr = Split(np, " ")
arr(0) = op
op = Join(arr, " ")
End If
End If
End Sub
В чем именно заключается ваш вопрос? Сложно ответить, потому что я не могу понять, о чем вы пытаетесь спросить. Скрипт в настоящее время работает? С какими проблемами вы столкнулись?