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

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.

steve the fish

Well-known Member
Joined
Oct 20, 2009
Messages
8,717
Office Version
  1. 365
Platform
  1. Windows
Hi

Try:

Code:
If product = 1000 Or product = 3000 Then
 

ksghumaria

New Member
Joined
Sep 9, 2014
Messages
9
Hey Steve
Thank for the reply.
Perfect answer, it works..
Thanks a lot :) .

Please help with the NewWB code. :rolleyes::)
 

steve the fish

Well-known Member
Joined
Oct 20, 2009
Messages
8,717
Office Version
  1. 365
Platform
  1. Windows
Which sheet are you trying to copy there?
 

ksghumaria

New Member
Joined
Sep 9, 2014
Messages
9

ADVERTISEMENT

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.
 

ksghumaria

New Member
Joined
Sep 9, 2014
Messages
9
Need Help with the Program. How to save unique sheets, save in temp, email and delete. Please Help!!:confused::rolleyes:
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,164,302
Messages
5,836,498
Members
430,436
Latest member
fefenouil

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
Top