Пожалуйста, разделите ваши коды на отдельные функции:
- Один для получения получателей
- Один для отправки электронной почты
Я заново создал вашу рабочую книгу.Приведенный ниже код будет выполнять ff:
- Сначала получить все коды компании
- Фильтровать список по балансовым единицам
- Получить список TO и CC
- Отправитьemail
Единственная оставленная здесь модификация - создание другой функции для отправки электронной почты (и передачи переменных).
Sub Send_Row_Or_Rows_2()
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
On Error GoTo ErrorHandler
' Initialization
' ==================================================
Dim shtRec As Worksheet: Set shtRec = ThisWorkbook.Sheets("rawdata")
Dim intLastRow As Long, intLastCol As Long ' for end cell
Dim i As Long, j As Long, k As Long, rngCell As Range ' for loops
Dim rngFilter As Range ' filter range
Dim strEmailTO As String, strEmailCC As String ' recipients
Dim arrCoCd() As String ' company codes
Dim arrEmailTO() As String ' TO recipients
Dim arrEmailCC() As String ' CC recipients
Dim arrEmailRec() As String, strEmailRec As String ' temporary variables
' Get Recipient header column indexes
Dim intRowHead As Integer: intRowHead = 4 ' header row
Dim intColCoCd As Integer: intColCoCd = 1 ' company code column
Dim intColTo As Integer: intColTo = 3 ' TO column
Dim intColCc As Integer: intColCc = 4 ' CC column
' Filter Recipients by Company Code
' ==================================================
With shtRec
' Remove filter
If Not .AutoFilter Is Nothing Then .AutoFilterMode = False
' Get end cell
With .Cells.SpecialCells(xlCellTypeLastCell)
intLastRow = .Row
intLastCol = .Column
End With
' Add filter
Set rngFilter = .Range(Cells(intRowHead, 1), Cells(intLastRow, intLastCol))
rngFilter.AutoFilter
' Get list of company codes
' =========================
ReDim arrCoCd(1 To intLastRow)
For i = (intRowHead + 1) To intLastRow ' exclude header
With .Cells(i, intColCoCd)
If .Value <> vbNullString Then
k = k + 1
arrCoCd(k) = VBA.Trim(.Value)
End If
End With
Next i
' Reset variable
k = 0
' Get unique values
' =========================
arrCoCd = FnStrUniqueArray(arrCoCd)
' Filter by Company Code
For i = LBound(arrCoCd) To UBound(arrCoCd)
If arrCoCd(i) <> vbNullString Then
rngFilter.AutoFilter Field:=intColCoCd, Criteria1:="=" & arrCoCd(i)
While Not Application.CalculationState = xlDone: DoEvents: Wend
' Get list only if with results
If .AutoFilter.Range.Columns(intColCoCd).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
Dim strRng As String
' Get TO list
' =========================
' Loop each visible cell in TO column
k = 0
strRng = .AutoFilter.Range.Offset(1, 0).Resize(.AutoFilter.Range.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Columns(intColTo).Address(False, False)
For Each rngCell In .Range(strRng)
' Remove spaces
strEmailRec = VBA.Trim(VBA.Replace(rngCell.Value, " ", ""))
' Get email addresses
arrEmailRec = VBA.Split(strEmailRec, ";")
' Add email addresses to list
If k = 0 Then k = k + 1 Else k = UBound(arrEmailTO) + 1
ReDim Preserve arrEmailTO(1 To k)
For j = LBound(arrEmailRec) To UBound(arrEmailRec)
arrEmailTO(k) = arrEmailRec(j)
Next j
' Remove duplicates in list
arrEmailTO = FnStrUniqueArray(arrEmailTO)
' Reset variables
strEmailRec = vbNullString
Erase arrEmailRec
Next rngCell
' Get CC list
' =========================
' Loop each visible cell in CC column
k = 0
strRng = .AutoFilter.Range.Offset(1, 0).Resize(.AutoFilter.Range.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Columns(intColCc).Address(False, False)
For Each rngCell In .Range(strRng)
' Remove spaces
strEmailRec = VBA.Trim(VBA.Replace(rngCell.Value, " ", ""))
' Get email addresses
arrEmailRec = VBA.Split(strEmailRec, ";")
' Add email addresses to list
If k = 0 Then k = k + 1 Else k = UBound(arrEmailCC) + 1
ReDim Preserve arrEmailCC(1 To k)
For j = LBound(arrEmailRec) To UBound(arrEmailRec)
arrEmailCC(k) = arrEmailRec(j)
Next j
' Remove duplicates in list
arrEmailCC = FnStrUniqueArray(arrEmailCC)
' Reset variables
strEmailRec = vbNullString
Erase arrEmailRec
Next rngCell
End If
' Join recipients list
strEmailTO = VBA.Join(arrEmailTO, ";")
strEmailCC = VBA.Join(arrEmailCC, ";")
' Send email
' <your code to send email passing variables - strEmailTO, strEmailCC, ...>
' Reset variables
Erase arrEmailTO
Erase arrEmailCC
End If
Next i
End With
ErrorHandler:
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Вот код для удаления дубликатов в массивах.Справка: vba получить уникальные значения из массива
Function FnStrUniqueArray(aTmpArray() As String)
Dim ctr As Long, cTmpCollection As New Collection, cTmpCollect
For Each cTmpCollect In aTmpArray
cTmpCollection.Add cTmpCollect, cTmpCollect
Next
' convert collection to array
ReDim aTmpArray(1 To cTmpCollection.Count)
For ctr = 1 To cTmpCollection.Count
aTmpArray(ctr) = cTmpCollection(ctr)
Next ctr
Set cTmpCollection = Nothing
FnStrUniqueArray = aTmpArray
End Function