Runtime Error 91 - I've 'Dim' and 'Set' already tho!?

StevenAncel

New Member
Joined
Dec 9, 2015
Messages
38
Im creating a macro for my work.

The oddest part of all this, is that the macro seems to run past the highlighted section.

It creates the email and puts the TO: CC: BCC: and copies over the content and everything.

It basically creates teh email just how i want, but gives an error ---- also doesnt 'close workbook' like ive stated in the code.

Please & Thank you for any assistance

Code:
Sub Email_Sender()'
'


    Dim sh As Worksheet
    Dim cell As Range
    Dim strbody As String
    Dim FileCell As Range
    Dim att As Range
    Dim rng As Range
    Dim strPath As String
    Dim wkbkSource As Workbook
    Dim OutApp As Object
    Dim OutMail As Object
    strPath = "T:\Store your files\INSTALLATIONS REPORTS\Completion Reports\"
    
    Set FileCell = Range("E2")
    Set sh = Sheets("Sheet1")
    Set OutApp = CreateObject("Outlook.Application")
    Set wkbkSource = Workbooks.Open(strPath & Range("E2").Value)
    
    For Each cell In sh.Range("B2").Cells.SpecialCells(xlCellTypeConstants)
    Set att = sh.Cells(cell.Row, 2).Range("E1:Z1")
    Set rng = ActiveWorkbook.Sheets("Breakdown").Range("a2:i81").SpecialCells(xlCellTypeVisible)


        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)


            With OutMail
                .to = cell.Value
                .cc = cell.Offset(0, 1).Value
                .bcc = cell.Offset(0, 2).Value
                .Subject = "COMPLETION REPORT " & cell.Offset(0, -1).Value
                .HTMLBody = "Good Afternoon, 
 
Please see the Completion Report for " & cell.Offset(0, -1).Value & RangetoHTML(rng)
                    If Trim(FileCell) <> "" Then
                        If Dir(strPath & FileCell.Value) <> "" Then
                            .Attachments.Add strPath & FileCell.Value
                        End If
                    End If


                .Display 'Or use .Display to show the message before sending
            End With


    Set OutMail = Nothing
    Set OutApp = Nothing
    End If
Next cell
'Closes Workbook
    Application.DisplayAlerts = False
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
End Sub
Function RangetoHTML(rng As Range)
'
'
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook


    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"


    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With


    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With


    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")


    'Close TempWB
    TempWB.Close savechanges:=False


    'Delete the htm file we used in this function
    Kill TempFile


    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing


End Function

The highlighted line is listed below
Code:
Set OutMail = OutApp.CreateItem(0)
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
You initialise OutApp before the For...Next loop, but set it to Nothing inside the loop...
 
Upvote 0
Sure. This:
Code:
Set OutApp = Nothing
needs to be after this:
Code:
Next cell

Otherwise your code works for the first item, then destroys the OutApp variable before trying to use it again without resetting it.
 
Upvote 0
I didnt realize i made it where it goes to the next cell, what would i do if i wanted it to just do the first row of information.

I need it to just do the one email based on the row '2' information

Sorry if this is too much to ask.

Nonetheless, Thank you!
 
Upvote 0
I figured it out, Im sure i did it the hard way. But this pulls directly from row 2 and makes an email
Code:
Sub Email_Sender()'
'


    Dim sh As Worksheet
    Dim cell As Range
    Dim strbody As String
    Dim FileCell As Range
    Dim att As Range
    Dim rng As Range
    Dim strPath As String
    Dim wkbkSource As Workbook
    Dim OutApp As Object
    Dim OutMail As Object
    Dim email As Range
    strPath = "T:\Store your files\INSTALLATIONS REPORTS\Completion Reports\"
    
    Set FileCell = Range("E2")
    Set sh = Sheets("Sheet1")
    Set email = Range("B2")
'Open Attachement
    Set wkbkSource = Workbooks.Open(strPath & Range("E2").Value)
    
    For Each emailcell In email


    Set rng = ActiveWorkbook.Sheets("Breakdown").Range("a2:i81").SpecialCells(xlCellTypeVisible)
    Set OutApp = CreateObject("Outlook.Application")


        If email.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)


            With OutMail
                .to = Workbooks("TestBook.xlsm").Sheets("Sheet1").Range("B2")
                .cc = Workbooks("TestBook.xlsm").Sheets("Sheet1").Range("C2")
                .bcc = Workbooks("TestBook.xlsm").Sheets("Sheet1").Range("D2")
                .Subject = "COMPLETION REPORT "
                .HTMLBody = "<BODY style=font-size:11pt;font-family:Calibri;color:#03497D;>Good Afternoon, <br/> <br/>Please see the Completion Report for " & RangetoHTML(rng)
                    If Trim(FileCell) <> "" Then
                        If Dir(strPath & FileCell.Value) <> "" Then
                            .Attachments.Add strPath & FileCell.Value
                        End If
                    End If


                .Display 'Or use .Display to show the message before sending
            End With


    Set OutMail = Nothing
    End If
Next emailcell
    Set OutApp = Nothing
'Closes Workbook
    Application.DisplayAlerts = False
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
End Sub
Function RangetoHTML(rng As Range)
'
'
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook


    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"


    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With


    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With


    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")


    'Close TempWB
    TempWB.Close savechanges:=False


    'Delete the htm file we used in this function
    Kill TempFile


    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing


End Function
 
Upvote 0
showing run time error 91 while coding :
Dim rowWB As Workbook
Dim rowWS As Worksheet
rowWS = ActiveWorkbook.Sheets("Shift Report")
Dim DataWB As Workbook
DataWB = Workbooks("\\selgjgdm00143d\Documents\RK SIR\Datasource\Shift Report Data.xlsx")
 
Upvote 0
You need to use Set with objects like workbooks and worksheets:

Code:
Set rowWS = ActiveWorkbook.Sheets("Shift Report")
Dim DataWB As Workbook
Set DataWB = Workbooks("\\selgjgdm00143d\Documents\RK SIR\Datasource\Shift Report Data.xlsx")
 
Upvote 0

Forum statistics

Threads
1,213,561
Messages
6,114,312
Members
448,564
Latest member
ED38

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top