Добрый день! Столкнулась с проблемой при написании макроса автоматической рассылки писем. Есть два листа в книге 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
Татьяна Басова, "автоматически"-это значит, что письма пересылаются из 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
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...