VBA MACRO отправляет пустые шаблоны только для одного пользователя - PullRequest
0 голосов
/ 18 февраля 2020

Я помогаю своей команде на работе изменить файл, который используется для отправки оставшихся командных праздников менеджерам. Макрос сделан не мной, я просто немного его модифицировал, но я не очень опытен. Проблема в том, что для большинства моих коллег файлы работают, но только для одного коллеги, когда она нажимает кнопку макроса, всплывающие сообщения электронной почты, вложение есть, но оно пустое !! Я правда не знаю в чем может быть проблема, у нее как установлены обновления, та же версия excel, что и у меня, патч в C: \ создал ..

Sub send_holidays_to_managers()
Dim subject, fileN As String

'-------------------------------------------------------------------------------------------
'------------------------------  SET VARIABLES ---------------------------------------------
'-------------------------------------------------------------------------------------------

' (output mail, subject)
Debug.Print Range("month2").Value
Debug.Print Range("year").Value
subject = "Holidays report" & " - " & Range("month2").Value & " " & Range("year").Value
' (output mail, body)
Const warningMessage As String = "***********************************************************************************************" & vbCrLf & "This message and any attachments are confidential and intended for the named addressee(s) only." & vbCrLf & "If you have received this message in error, please notify immediately the sender, then delete the message. Any unauthorized modification, edition, use or dissemination is prohibited." & vbCrLf & "The sender shall not be liable for this message if it has been modified, altered, falsified, infected by a virus or even edited or disseminated without authorization." & vbCrLf & "***********************************************************************************************"

Dim messageFinal As String
messageFinal = "Hello," & vbCrLf & vbCrLf & _
    "Please find attached the Holidays report of your Team Members." & vbCrLf & vbCrLf & _
    "Best regards,"

' Temporary XLSX file, sent to each manager
' THE PATH MUST EXIST !!!
fileN = "C:\tmp\Team_holidays_report_" & Range("E1").Value & " " & Range("year").Value & ".xlsx"

'-------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------

Dim line, lineS2, lineWBTemp As Integer
Dim sheetHolidays, sheetMails, BU, lastBU, emailManager, wbPattern, wbTemp, current_BU As String
Dim OutApp, OutMail, NewBook As Object
Dim BU_list As Excel.Range

sheetHolidays = "Summary"
sheetMails = "Mails"
wbPattern = ThisWorkbook.Name
Set OutApp = CreateObject("Outlook.Application")

' DATA UPDATE
' Remove old data
Sheets("Summary").ListObjects("Recap").Range.AutoFilter Field:=2
If Not (Sheets(sheetHolidays).ListObjects("Recap").DataBodyRange Is Nothing) Then
   Sheets(sheetHolidays).ListObjects("Recap").DataBodyRange.Rows.Delete
End If

' Update connections
'ActiveWorkbook.RefreshAll

' Copy paste the new one
Range("HOLIDAYS[ID]").Copy
Sheets("Summary").Select
Range("Recap[ID]").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
' Create directory 'C:\tmp'
If Not (directoryExists("C:\tmp")) Then
    MkDir ("C:\tmp")
End If

' OUTPUT WORKBOOK
Application.DisplayAlerts = False
Set NewBook = Workbooks.Add
With NewBook
    .Title = "holidays_report"
    .SaveAs Filename:=fileN
End With
wbTemp = NewBook.Name

' Set the first line here
line = 8
lineWBTemp = 8

Workbooks(wbPattern).Activate
'Application.Goto Workbooks(wbPattern).Sheets(sheetHolidays).Range("A1")

'Sheets("Mails").Select
Set BU_list = Range("Mails[BU]")

For Each c In BU_list.SpecialCells(xlCellTypeVisible)
    current_BU = c
    emailManager = managerMail(current_BU)

    ' Filter with the BU
    Sheets("Summary").Select
    Application.GoTo Workbooks(wbPattern).Sheets(sheetHolidays).Range("A1")
    ActiveSheet.ListObjects("Recap").Range.AutoFilter Field:=2, Criteria1:=current_BU

    'Manager does not exist
    If emailManager = "" Then
        MsgBox "The manager's trigram " & current_BU & " does not exist in the list, " & sheetMails

    Else ' Manager exists

        On Error Resume Next
        Set OutMail = OutApp.CreateItem(0)


        Workbooks.Open fileN
        Set NewBook = Workbooks(wbTemp)


        ' Clear old sheet
        Application.GoTo Workbooks(wbTemp).Sheets("Sheet1").Activate
        If Selection.Count <= 1 Then
            Columns("A:W").Select
        End If
        Selection.Clear

        ' Copy
        Application.GoTo Workbooks(wbPattern).Sheets(sheetHolidays).Activate
        ActiveSheet.Range(Range("B1:W6"), Range("Recap[#All]")).Select
        Selection.Copy

        ' Paste
        Application.GoTo Workbooks(wbTemp).Sheets("Sheet1").Activate
        ActiveSheet.Range("A1").Select
        ActiveSheet.Paste
        Range("C1").Select

        ' Avoid formulas (not possible before)
        Selection.Copy
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

        ' Columns Width
        Columns("A:X").EntireColumn.AutoFit

        ' Remove the buttons
        ActiveSheet.Shapes.Range(Array("Green_button")).Delete
        ActiveSheet.Shapes.Range(Array("Orange_button")).Delete

        ' Save and Close
        NewBook.Save
        NewBook.Close


        ' Prepare and send email
        If debugg = True Then
            With OutMail
                .To = mailDebug
                .CC = ""
                .BCC = ""
                .subject = subject
                .Body = "This mail should have been sent to : " & emailManager & vbCrLf & vbCrLf & messageFinal & vbCrLf & warningMessage
                .Attachments.Add fileN
                '.Send
                .Display
            End With
         Else
            With OutMail
                .To = emailManager
                .CC = ""
                .BCC = ""
                .subject = subject
                .Body = messageFinal & vbCrLf & warningMessage
                .Attachments.Add fileN
                '.Send
                .Display
            End With
        End If

        Set OutMail = Nothing
        On Error GoTo 0


    End If

Next c

Set OutApp = Nothing


End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...