Need Help with this program to create unique workbook, save, mail and delete

ksghumaria

New Member
Joined
Sep 9, 2014
Messages
9
Hi I'm trying to modify the excel program to copy customised worksheet in new workbook, saving it as temp then mailing this workbook and then deleting it.
I am having following difficulties:
1. If- else if statement not working
2. Showing object error

Sub Send_sheet()

Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim DataWB As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim NewWB As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim k As Worksheet
Dim product

On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")

With Application
.EnableEvents = False
.ScreenUpdating = True

End With

Set DataWB = Sheets("DATA")
Set FilterRange = DataWB.Range("A1:K" & DataWB.Rows.Count)
FieldNum = 2 'Filter column = B because the filter range start in column A

Set Cws = Worksheets.Add
Cws.Name = "Email IDs"

FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True

Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
If Rcount >= 2 Then
For Rnum = 2 To Rcount
product = Sheets("DATA").Cells(Rnum, 4)
'If the unique value is a mail addres create a mail
If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then

'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value

'Copy the visible data in a new workbook
With DataWB.AutoFilter.Range
On Error Resume Next
'MsgBox (product)
If product = 1000 Or 3000 Then
Sheets("A").Select
ElseIf product = 2000 Then
Sheets("B").Select
ElseIf product = 4000 Then
Sheets("C”).Select
End If
Range("C5").Value = Sheets("DATA").Cells(Rnum, 1).Value
Range("C6").Value = Sheets("DATA").Cells(Rnum, 3).Value
Range("C9").Value = Sheets("DATA").Cells(Rnum, 7).Value
Range("C12").Value = Sheets("DATA").Cells(Rnum, 5).Value
Range("E16").Value = Sheets("DATA").Cells(Rnum, 8).Value
Range("E18").Value = Sheets("DATA").Cells(Rnum, 9).Value
Range("E19").Value = Sheets("DATA").Cells(Rnum, 10).Value
Range("E23").Value = Sheets("DATA").Cells(Rnum, 11).Value
Range("I18").Value = 12
k = ActiveSheet.copy
On Error GoTo 0
End With

NewWB = Workbook.Add ' showing error

ThisWorkbook.Sheets.k.Copy before:=NewWB.Sheets(1) 'showing error
Application.CutCopyMode = False
Range("A4").Select
ActiveWindow.FreezePanes = True

'Create a file name
TempFilePath = Environ$("temp") & "\"
TempFileName = DataWB.Parent.Name _
& " " & Format(Now, "dd-mmm-yy h-mm-ss")

If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2013
FileExtStr = ".xlsx": FileFormatNum = 51
End If

'Save, Mail, Close and Delete the file
Set OutMail = OutApp.CreateItem(0)

With NewWB
.SaveAs TempFilePath & TempFileName _
& FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = Cws.Cells(Rnum, 1).Value
.Subject = "XYZABC12345"
.Attachments.Add NewWB.FullName
.Body = "Hello Everyone”
.display
End With
On Error GoTo 0
.Close savechanges:=False
End With

Set OutMail = Nothing
Kill TempFilePath & TempFileName & FileExtStr
End If

'Close AutoFilter
DataWB.AutoFilterMode = False

Next Rnum
End If

cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True

With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
 
Last edited:

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
Hey Steve
Thank for the reply.
Perfect answer, it works..
Thanks a lot :) .

Please help with the NewWB code. :rolleyes::)
 
Upvote 0
The sheet 'if- Then-elseif' condition selects. That will become the active sheet,I want that sheet to be converted as new workbook for mailing.
 
Upvote 0

Forum statistics

Threads
1,213,517
Messages
6,114,085
Members
448,548
Latest member
harryls

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