locked
Need to know where I'm going wrong? RRS feed

  • Question

  • Attached is a script that I've inherited involving emailing attachments that are titled with the cost center numbers in the first 8 figures of the attachment name.

    The code tells the script to replace the email with a default email address if a Vlookup populates #N/A. Unfortunately, it is only recognizing 20% of the attachments against the distribution list.

    Could someone read this and tell me where it's going wrong?

    Option Explicit
    
    Sub Main()
    
    Const TEST_MODE = False
    Dim strTargetFolder As String
    Dim strFileName As String
    Dim strEmailAddresses As String
    Dim dblCostCenter As String
    Dim objMailDictionary As Object
    Dim objFileDictionary As Object
    Dim vrtFileNames() As Variant
    Dim vrtCostCenters() As Variant
    Dim i As Long
    Dim j As Long
    Dim k As Integer
    Dim blnResult As Boolean
    Dim strPERIOD
    Dim strFolder
    Dim targetName As String
    Dim ans As Variant
    Dim lRow As Long
    Dim sPath As String
    Dim sFname As String
    Dim rRange As Range
    Dim strPATH As String
    Dim aDr As String
    Dim aDr2 As String
    
    
    strTargetFolder = GetFolder
    
    
    If strTargetFolder = "None" Then
        Exit Sub
    End If
    
       'buildFileDictionary (strTargetFolder)
       
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
       
       'strTargetFolder = GetFolderName("Select a folder")
       If strTargetFolder = "" Then
          Exit Sub
       End If
       sPath = strTargetFolder & "/"
       sFname = Dir(sPath & "*.*", vbNormal)
       ActiveWorkbook.Sheets("Directory").Select
       Do Until sFname = ""
          lRow = lRow + 1
        If Left(sFname, 7) <> "AllCost" Then
          Cells(lRow, "d").Value = sFname
          If InStr(sFname, "_") > 0 Then
            Cells(lRow, "e").Value = Left(sFname, (InStr(sFname, "_") - 1))
          Else
            Cells(lRow, "e").Value = Left(sFname, (InStr(sFname, ".") - 1))
          End If
          Cells(lRow, "f").Select
          ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],RC[-5]:R[500]C[-1],2,False)"
        End If
        sFname = Dir
       Loop
       
        Range("D1").Select
         Range(Selection, Selection.End(xlDown).Offset(0, 2)).Select
        Selection.NumberFormat = "0"
        Set rRange = Selection
        Range("H1") = rRange.Address
        Range("I1") = rRange.Rows.Count
        Selection.Copy
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Application.CutCopyMode = False
        
        'Exit Sub
        
    
        aDr = Range("H1")
        Columns("F:F").Select
        Selection.Replace What:="#N/A", Replacement:="kim.mcdonald@wrigley.com", _
            LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
            False, ReplaceFormat:=False
        
        ActiveWorkbook.Worksheets("Directory").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("Directory").Sort.SortFields.Add Key:=Range( _
            "E1:E2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
        With ActiveWorkbook.Worksheets("Directory").Sort
            .SetRange Range(aDr)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        k = Range(aDr).Rows.Count
        
        j = 3
        For i = 1 To k
            lRow = i
    
            If Cells(lRow, "f") = "kim.mcdonald@wrigley.com" Then
                aDr = "e" & lRow
                aDr2 = "G" & j
                ans = ActiveWorkbook.Sheets("Directory").Range(aDr)
                ActiveWorkbook.Sheets("Reference").Range(aDr2) = ans
                j = j + 1
                
            End If
        Next
        
    aDr = Range("H1")
    Set rRange = Range(aDr)
    
    'Set objMailDictionary = BuildMailDictionary()
    'Set objFileDictionary = BuildFileDictionary(strTargetFolder)
    
    'vrtFileNames = objFileDictionary.Index
    'vrtCostCenters = objFileDictionary.items
    strPATH = ActiveWorkbook.Sheets("Reference").Range("D2") & "\P" & ActiveWorkbook.Sheets("Reference").Range("E2") _
       & "\Wired\"
    
    For i = 1 To rRange.Rows.Count
    
    '    'Verify the cost center value is a number.
    
            lRow = i
            strEmailAddresses = Cells(lRow, "f")
            strFileName = Cells(lRow, "D")
            dblCostCenter = Cells(lRow, "E")
        If dblCostCenter <> "" Then
            If Len(strEmailAddresses) > 0 Then
                If TEST_MODE Then
                    MsgBox "File Name: " & strFileName & vbCrLf & _
                           "Cost Center: " & dblCostCenter & vbCrLf & _
                           "Email: " & strEmailAddresses, vbInformation, "Test Mode - Success"
                Else
                    blnResult = SendEmail(strEmailAddresses, strFileName, dblCostCenter, strPATH)
                End If
            Else
                If TEST_MODE Then
                    MsgBox "File Name: " & strFileName & vbCrLf & _
                           "Cost Center: " & dblCostCenter, vbInformation, "Test Mode - No Email Addresses Found"
                Else
                    MsgBox "File Name: " & strFileName & vbCrLf & _
                           "Cost Center: " & dblCostCenter, vbInformation, "No Email Addresses Found"
                End If
            End If
        Else
            If TEST_MODE Then
                MsgBox "File Name: " & strFileName, vbInformation, "Test Mode - No Cost Center Found"
            Else
                MsgBox "File Name: " & strFileName, vbInformation, "No Cost Center Found"
            End If
        End If
    Next
    
                
    
    ActiveWorkbook.Sheets("Directory").Activate
    Range("D:i").Clear
    Range("A1").Select
    ActiveWorkbook.Sheets("Reference").Activate
    strPERIOD = Range("E2")
    Range("G2").Select
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    ans = MsgBox("The Email Creation for Period " & strPERIOD & " is complete!!", vbOKOnly + vbInformation, "EMAILS CREATED")
    
    
    End Sub
    
    
    
    
    
    Private Function GetFolder() As String
    
    Dim objFolderPicker As FileDialog
    Set objFolderPicker = Application.FileDialog(msoFileDialogFolderPicker)
    Dim targetName As String
    Dim ans As Variant
    Dim strPERIOD As String
    Dim strFolder As String
    
    targetName = Range("E2")
    
        ans = MsgBox("Is PERIOD " & targetName & " the correct period?", vbInformation + vbYesNo, "CONFIRM PERIOD")
        
         If ans = vbNo Then
            targetName = InputBox("Type the Correct Period", "CHOOSE PERIOD", "TYPE CORRECT PERIOD", vbInformation + vbOKCancel)
    
    
            
            If targetName = "" Or targetName = "TYPE CORRECT PERIOD" Then
                ans = MsgBox("Please re-run 'Email Creation' and choose the correct period", vbCritical + vbOKOnly, "CHOOSE PERIOD")
                Exit Function
            End If
            
        End If
        
    
    Range("E2") = targetName
    
    strPERIOD = Range("E2")
    strFolder = Range("D2")
    strFolder = strFolder & "\P" & strPERIOD & "\Wired\"
        ChDrive "Y"
        ChDir strFolder
    
    
    With objFolderPicker
        .InitialFileName = strFolder
    
        .AllowMultiSelect = False
        .ButtonName = "Scan Folder"
        .Title = "Select Report Folder"
        
        If .Show = -1 Then
            GetFolder = .SelectedItems.Item(1)
        Else
            GetFolder = "None"
        End If
    End With
        
    End Function
    
    Private Function GetFileNames(strTargetFolder As String) As String()
    
    Dim strFileNames() As String
    Dim i As Integer
    
    With Application.FileSearch
        .LookIn = strTargetFolder
        .FileType = msoFileTypeExcelWorkbooks
        If .Execute > 0 Then
            ReDim strFileNames(.foundFiles.Count)
            For i = 1 To .foundFiles.Count
                strFileNames(i) = .foundFiles(i)
            Next
        End If
    End With
    
    GetFileNames = strFileNames
    
    End Function
    
    Private Function SendEmail(strEmailAddresses As String, strFileName As String, dblCostCenter As String, strPATH As String) As Boolean
    'On Error GoTo ERROR_HANDLER
    
    Dim objOutlookApp As Object
    Dim objMailItem As Object
    Dim objSafeMailItem As Object
    Dim i As Integer
    Dim strPERIOD As String
    
    strPERIOD = ActiveWorkbook.Sheets("Reference").Range("E2")
    
    Set objOutlookApp = CreateObject("Outlook.Application")
    'Cannot use the constant "olMailItem" - use the value of the constant instead, which is 0.
    Set objMailItem = objOutlookApp.CreateItem(0)
    
    With objMailItem
        .To = strEmailAddresses
        .Subject = "Period " & strPERIOD & " - Wired and Wireless Report Details " & dblCostCenter
        .HTMLBody = "Greetings,<BR><BR>Please see attached Wired and Wireless Report Details " _
         & "to support P11 2014 Journal Entry.  <BR><BR>" _
         & "PLEASE SUBMIT A HELP CENTER (HelpCenter@wrigley.com) TICKET FOR ANY CHANGES OR CORRECTIONS!!!  <BR><BR>" _
         & "(americasittelecom@Wrigley.com)<BR><BR>" _
          & "Thank you for your support.<BR><BR>" _
          & "<BR><BR>Warm regards,<BR><BR>Americas IT Telecom Group"
        .Attachments.Add (strPATH & strFileName)
    End With
    
    Set objSafeMailItem = CreateObject("Redemption.SafeMailItem")
    objSafeMailItem.Item = objMailItem
    objSafeMailItem.Send
    
    Application.Wait (Now + TimeValue("00:00:03"))
    
    ERROR_HANDLER:
    
    Set objOutlookApp = Nothing
    Set objMailItem = Nothing
    Set objSafeMailItem = Nothing
    
    If Err.Number = 0 Then
        SendEmail = True
    Else
        SendEmail = False
    End If
    
    End Function
    


    Thursday, February 5, 2015 12:07 PM