Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Объединение 2х макросов в 1 - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Объединение 2х макросов в 1 (Макросы/Sub)
Объединение 2х макросов в 1
yaropolk Дата: Четверг, 11.04.2024, 12:28 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

2021
Я начинающий в VBA. Сильно не пинайте.
Есть файл, с данными по сотрудникам. Есть 2 макроса, которые по отдельности работают как надо. Первый - формирует письма на получателей (если почта получателя встречается 10 раз, будет сформированы 10 писем), с указанием сотрудников, у кого срок меньше, либо равен, 9. Второй макрос - формирует письма, без повторений получателя (т.е. если в получателях находится 10 строк для отправки, он собирает эти 10 строк в 1 письмо, а не 10 писем). И я хочу объединить эти 2 макроса, чтобы он формировал 1 письмо со всеми сотрудниками (на 1 получателя), у кого срок меньше либо равен 9. Пример документа и сами макросы ниже

[vba]
Код
Public Sub SendMailDueDate()
Dim xRgDate As Range
Dim xRgSend As Range
Dim xRgText As Range
Dim xRgDone As Range
Dim xOutApp As Object
Dim xMailItem As Object
Dim xLastRow As Long
Dim vbCrLf As String
Dim xMailBody As String
Dim xRgDateVal As String
Dim xRgSendVal As String
Dim xMailSubject As String
Dim y As Long
On Error Resume Next
Set xRgDate = Range("F2:F7") 'Дата окончания
If xRgDate Is Nothing Then Exit Sub
Set xRgSend = Range("E2:E7") 'Почта
If xRgSend Is Nothing Then Exit Sub
Set xRgText = Range("B2:B7") 'ФИО
If xRgText Is Nothing Then Exit Sub
xLastRow = xRgDate.Rows.Count
Set xRgDate = xRgDate(1)
Set xRgSend = xRgSend(1)
Set xRgText = xRgText(1)
Set xOutApp = CreateObject("Outlook.Application")
For y = 1 To xLastRow
xRgDateVal = ""
xRgDateVal = xRgDate.Offset(y - 1).Value
If xRgDateVal <> "" Then
If CDate(xRgDateVal) - Date <= 10 And CDate(xRgDateVal) - Date > 0 Then
xRgSendVal = xRgSend.Offset(y - 1).Value
xMailSubject = "Окончание сертификата"
vbCrLf = ""
            xMailBody = "Добрый день! сертификат кончается у " & xRgText.Offset(y - 1).Value & vbCrLf
Set xMailItem = xOutApp.CreateItem(0)
With xMailItem
.Subject = xMailSubject
.To = xRgSendVal
.CC = ""
.BCC = ""
.HTMLBody = xMailBody
.Display
'.Send
End With
Set xMailItem = Nothing
End If
End If
Next
Set xOutApp = Nothing
End Sub
[/vba]

[vba]
Код
Sub SendMail()
  
    Const olMailItem% = 0
    Const FirstRow% = 2
    Dim i&, j&, LastRow&, T$, vX, OutlookApp As Object, Dic As Object, Dic2 As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    With ActiveSheet: LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row: End With
    Set Dic = CreateObject("Scripting.Dictionary"): Dic.CompareMode = 1
    Set Dic2 = CreateObject("Scripting.Dictionary"): Dic2.CompareMode = 1
    For i = FirstRow To LastRow
        T = Cells(i, 2)
        vX = Cells(i, 5)
        Dic.Item(vX) = Dic.Item(vX) & T & vbCrLf
        If Not IsEmpty(Cells(i, 5)) Then Dic2.Item(vX) = Cells(i, 5)
    Next i
    For Each vX In Dic.Keys
        If Len(Dic2.Item(vX)) Then
                    With OutlookApp.CreateItem(olMailItem)
                        .to = Dic2.Item(vX)
                        .Subject = "Окончание сертификата"
                        .Body = "Сертификат кончается: " & vbCrLf & Dic.Item(vX)
                        .display
                    End With
        End If
    Next vX
    Set OutlookApp = Nothing
    Set Dic = Nothing

End Sub
[/vba]
К сообщению приложен файл: book1.xlsx (11.9 Kb)
 
Ответить
СообщениеЯ начинающий в VBA. Сильно не пинайте.
Есть файл, с данными по сотрудникам. Есть 2 макроса, которые по отдельности работают как надо. Первый - формирует письма на получателей (если почта получателя встречается 10 раз, будет сформированы 10 писем), с указанием сотрудников, у кого срок меньше, либо равен, 9. Второй макрос - формирует письма, без повторений получателя (т.е. если в получателях находится 10 строк для отправки, он собирает эти 10 строк в 1 письмо, а не 10 писем). И я хочу объединить эти 2 макроса, чтобы он формировал 1 письмо со всеми сотрудниками (на 1 получателя), у кого срок меньше либо равен 9. Пример документа и сами макросы ниже

[vba]
Код
Public Sub SendMailDueDate()
Dim xRgDate As Range
Dim xRgSend As Range
Dim xRgText As Range
Dim xRgDone As Range
Dim xOutApp As Object
Dim xMailItem As Object
Dim xLastRow As Long
Dim vbCrLf As String
Dim xMailBody As String
Dim xRgDateVal As String
Dim xRgSendVal As String
Dim xMailSubject As String
Dim y As Long
On Error Resume Next
Set xRgDate = Range("F2:F7") 'Дата окончания
If xRgDate Is Nothing Then Exit Sub
Set xRgSend = Range("E2:E7") 'Почта
If xRgSend Is Nothing Then Exit Sub
Set xRgText = Range("B2:B7") 'ФИО
If xRgText Is Nothing Then Exit Sub
xLastRow = xRgDate.Rows.Count
Set xRgDate = xRgDate(1)
Set xRgSend = xRgSend(1)
Set xRgText = xRgText(1)
Set xOutApp = CreateObject("Outlook.Application")
For y = 1 To xLastRow
xRgDateVal = ""
xRgDateVal = xRgDate.Offset(y - 1).Value
If xRgDateVal <> "" Then
If CDate(xRgDateVal) - Date <= 10 And CDate(xRgDateVal) - Date > 0 Then
xRgSendVal = xRgSend.Offset(y - 1).Value
xMailSubject = "Окончание сертификата"
vbCrLf = ""
            xMailBody = "Добрый день! сертификат кончается у " & xRgText.Offset(y - 1).Value & vbCrLf
Set xMailItem = xOutApp.CreateItem(0)
With xMailItem
.Subject = xMailSubject
.To = xRgSendVal
.CC = ""
.BCC = ""
.HTMLBody = xMailBody
.Display
'.Send
End With
Set xMailItem = Nothing
End If
End If
Next
Set xOutApp = Nothing
End Sub
[/vba]

[vba]
Код
Sub SendMail()
  
    Const olMailItem% = 0
    Const FirstRow% = 2
    Dim i&, j&, LastRow&, T$, vX, OutlookApp As Object, Dic As Object, Dic2 As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    With ActiveSheet: LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row: End With
    Set Dic = CreateObject("Scripting.Dictionary"): Dic.CompareMode = 1
    Set Dic2 = CreateObject("Scripting.Dictionary"): Dic2.CompareMode = 1
    For i = FirstRow To LastRow
        T = Cells(i, 2)
        vX = Cells(i, 5)
        Dic.Item(vX) = Dic.Item(vX) & T & vbCrLf
        If Not IsEmpty(Cells(i, 5)) Then Dic2.Item(vX) = Cells(i, 5)
    Next i
    For Each vX In Dic.Keys
        If Len(Dic2.Item(vX)) Then
                    With OutlookApp.CreateItem(olMailItem)
                        .to = Dic2.Item(vX)
                        .Subject = "Окончание сертификата"
                        .Body = "Сертификат кончается: " & vbCrLf & Dic.Item(vX)
                        .display
                    End With
        End If
    Next vX
    Set OutlookApp = Nothing
    Set Dic = Nothing

End Sub
[/vba]
Автор - yaropolk
Дата добавления - 11.04.2024 в 12:28
Gustav Дата: Четверг, 11.04.2024, 14:41 | Сообщение № 2
Группа: Админы
Ранг: Участник клуба
Сообщений: 2797
Репутация: 1161 ±
Замечаний: ±

начинал с Excel 4.0, видел 2.1
Если правильно понял, надо во второй макрос добавить условие про 9 дней (или про 10, как указано в коде <= 10). Ниже я добавил 4 строки с комментарием "ДОБАВЛЕНО ..." в Ваш код и название процедуры чуть изменил (_v2 = версия 2), чтобы не конфликтовало:
[vba]
Код
Sub SendMail_v2()

    Dim xRgDateVal As String 'ДОБАВЛЕНО ----- 1
    Const olMailItem% = 0
    Const FirstRow% = 2
    Dim i&, j&, LastRow&, T$, vX, OutlookApp As Object, Dic As Object, Dic2 As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    With ActiveSheet: LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row: End With
    Set Dic = CreateObject("Scripting.Dictionary"): Dic.CompareMode = 1
    Set Dic2 = CreateObject("Scripting.Dictionary"): Dic2.CompareMode = 1
    For i = FirstRow To LastRow
        xRgDateVal = Cells(i, 6) 'ДОБАВЛЕНО ----- 2
        If CDate(xRgDateVal) - Date <= 10 And CDate(xRgDateVal) - Date > 0 Then 'ДОБАВЛЕНО ----- 3
            T = Cells(i, 2)
            vX = Cells(i, 5)
            Dic.Item(vX) = Dic.Item(vX) & T & vbCrLf
            If Not IsEmpty(Cells(i, 5)) Then Dic2.Item(vX) = Cells(i, 5)
        End If 'ДОБАВЛЕНО ----- 4
    Next i
    For Each vX In Dic.Keys
        If Len(Dic2.Item(vX)) Then
                    With OutlookApp.CreateItem(olMailItem)
                        .to = Dic2.Item(vX)
                        .Subject = "Окончание сертификата"
                        .Body = "Сертификат кончается: " & vbCrLf & Dic.Item(vX)
                        .display
                    End With
            MsgBox "Сертификат кончается: " & vbCrLf & Dic.Item(vX)
        End If
    Next vX
    Set OutlookApp = Nothing
    Set Dic = Nothing

End Sub
[/vba]
Проверьте, так ли, как хотели, получается? Оно?

МОИ: Ник, Tip box: 41001663842605
 
Ответить
СообщениеЕсли правильно понял, надо во второй макрос добавить условие про 9 дней (или про 10, как указано в коде <= 10). Ниже я добавил 4 строки с комментарием "ДОБАВЛЕНО ..." в Ваш код и название процедуры чуть изменил (_v2 = версия 2), чтобы не конфликтовало:
[vba]
Код
Sub SendMail_v2()

    Dim xRgDateVal As String 'ДОБАВЛЕНО ----- 1
    Const olMailItem% = 0
    Const FirstRow% = 2
    Dim i&, j&, LastRow&, T$, vX, OutlookApp As Object, Dic As Object, Dic2 As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    With ActiveSheet: LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row: End With
    Set Dic = CreateObject("Scripting.Dictionary"): Dic.CompareMode = 1
    Set Dic2 = CreateObject("Scripting.Dictionary"): Dic2.CompareMode = 1
    For i = FirstRow To LastRow
        xRgDateVal = Cells(i, 6) 'ДОБАВЛЕНО ----- 2
        If CDate(xRgDateVal) - Date <= 10 And CDate(xRgDateVal) - Date > 0 Then 'ДОБАВЛЕНО ----- 3
            T = Cells(i, 2)
            vX = Cells(i, 5)
            Dic.Item(vX) = Dic.Item(vX) & T & vbCrLf
            If Not IsEmpty(Cells(i, 5)) Then Dic2.Item(vX) = Cells(i, 5)
        End If 'ДОБАВЛЕНО ----- 4
    Next i
    For Each vX In Dic.Keys
        If Len(Dic2.Item(vX)) Then
                    With OutlookApp.CreateItem(olMailItem)
                        .to = Dic2.Item(vX)
                        .Subject = "Окончание сертификата"
                        .Body = "Сертификат кончается: " & vbCrLf & Dic.Item(vX)
                        .display
                    End With
            MsgBox "Сертификат кончается: " & vbCrLf & Dic.Item(vX)
        End If
    Next vX
    Set OutlookApp = Nothing
    Set Dic = Nothing

End Sub
[/vba]
Проверьте, так ли, как хотели, получается? Оно?
Автор - Gustav
Дата добавления - 11.04.2024 в 14:41
yaropolk Дата: Понедельник, 15.04.2024, 08:54 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

2021
Да, то что надо)) Спасибо большое)))
 
Ответить
СообщениеДа, то что надо)) Спасибо большое)))
Автор - yaropolk
Дата добавления - 15.04.2024 в 08:54
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Объединение 2х макросов в 1 (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!