Страницы: 1
RSS
Автоматическая рассылка писем из EXCEL через OUTLOOK, в массив вставляется много отступов
 
Добрый день! Столкнулась с проблемой при написании макроса автоматической рассылки писем. Есть два листа в книге Excel. На одном в таблице располагаются 1 столбец - ФИО (директора), 2 столбец - email (директора). На другом ФИО (директора), email (директора), несколько фамилий сотрудников у каждого директора своё количество сотрудников. Макрос работает отлично, при помощи массива берем только те ФИО сотрудников со второго листа, которые принадлежат email директора с первого. Но при отправке сообщений, первому получателю (директору) вставляются все ФИО сотрудников, которые ему принадлежат и много пробелов, второму соответственно много пробелов, потом те, которые ему принадлежат. И т.д. Сорри, если сложно описала задачу, но понимаю, что он берет пустые значения, вместо ФИО сотрудников, которые ему не принадлежат, но не знаю, как починить. Изначально ФИО вставлялись просто в одну строку без запятых, теперь я добавила в код перенос на новую строку с помощью <br> и получилось вот так. Просто в одну строку точно не устраивает.
Код
Public Sub Email_dir()
Dim objOutlook As Object, objMail As Object
Dim sTo As String, sSubject As String, sBody As String, sAttachment As String, sPicture As String
Dim I, J, X As Integer
Dim Part, RowCount, Counter As Variant
Dim Vintage1(), Vintage2() As Variant
'
Workbooks.Open Filename:="X:\....xlsm"
Sheets("...").Select
RowCount = 0
End(xlDown).Row
RowCount = Cells(2, 2).End(xlDown).Row
For X = 2 To RowCount
sTo = Cells(X, 2)
'
Sheets("...").Select

RowCount = 0
End(xlDown).Row
RowCount = Cells(2, 2).End(xlDown).Row
ReDim Vintage1(RowCount, 2)
'
For I = 1 To RowCount
For J = 2 To 3
'
Vintage1(I, J - 1) = Cells(I + 1, J)
Next J
Next I
'
ReDim Vintage2(RowCount, 1)
'
For I = 1 To RowCount
If Vintage1(I, 1) = sTo Then
Vintage2(I, 1) = Vintage1(I, 2)

End If
Next I

For I = 1 To RowCount

sBody = sBody & Vintage2(I, 1) & "<br>"
Next I
'
If objOutlook Is Nothing Then
Set objOutlook = CreateObject("Outlook.Application")
End If
'
Set objOutlook = GetObject(, "Outlook.Application")
Err.Clear
Set objMail = objOutlook.CreateItem(0)
If Err.Number <> 0 Then Set objOutlook = Nothing: Set objMail = Nothing: Exit Sub
'
sSubject = ...
sPicture = "..."

With objMail
.To = sTo 
.CC = "" 
.BCC = ""
.Subject = sSubject 
.HTMLBody = sBody 

If Dir(sPicture, 16) <> "" Then
.Attachments.Add sPicture

.HTMLBody = .HTMLBody _
& "<p></p>" _
& "<img src=cid:" & Replace(Dir(sPicture, 16), " ", "%20") & ">" _
& "<p><i>...</i></p>"
'" height=240 width=180>" 
End If
If sAttachment <> "" Then
If Dir(sAttachment, 16) <> "" Then
.Attachments.Add sAttachment 
End If
End If
.Send 
End With
'
Set objOutlook = Nothing: Set objMail = Nothing
Application.ScreenUpdating = True
'
sBody = ""
Erase Vintage1
Erase Vintage2
Sheets("Ñîòð").Select
Next X

'
'Windows("Procedure_trigger.xlsm").Activate
'Sheets("ÄÊÖ").Select
ActiveWorkbook.Save
'
'Application.Quit
End Sub
Изменено: vikttur - 21.09.2021 10:18:10
 
Где листы? Где макрос?
 
Цитата
Татьяна Басова написал:
теперь я добавила в код перенос на новую строку с помощью
и получилось вот так.
значит надо убрать там, где это не нужно. Через If, например. Но без кода никто ничего не подскажет.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Татьяна Басова,
"автоматически"-это значит, что письма пересылаются из EXCEL через OUTLOOK в определённое в каком то столбце дату и время или после выделения определённых ячеек (к которым привязаны письма) и нажатия "Пуск"?
 
Добавила код.  
 
Цитата
Татьяна Басова написал:
Добавила код
очень страшно выглядит...У нас на форуме для оформления кодов есть кнопочка <...>. Используйте её. А то в таком виде читать код совершенно невозможно.
Чисто теоретически, я думаю, что можно починить, изменив эту часть кода:
Код
For I = 1 To RowCount
sBody = sBody & Vintage2(I, 1) & "<br>"
Next I
на такую(как и предлагал)
Код
For I = 1 To RowCount
if Trim(Vintage2(I, 1)) <> "" then 'добавляем только если ячейка не пустая
sBody = sBody & Vintage2(I, 1) & "<br>"
End if
Next I
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Дмитрий(The_Prist) ЩербаковОтлично, работает!!! решение найдено, спасибо!!!
Страницы: 1
Наверх