Question : Add-in aditional words in Excel File Name

Hi,

I need Experts help to re-write this script to allow add-in information from sheet-2 (Detail Task), cell-C2 for file name creation.

By doing this, the file name will be: "Weekly Summary Report + C2(Sheet-2).

Hope this is possible. I've attached the script that i'm using now for your perusal.

Code Snippet:

         
           
             1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:

           
           
             Sub SendEmail()
Dim wb As Workbook
Dim ws As Worksheet
Dim fName As String
Dim SendTo As String
Dim OutlookApp As Object
Dim MItem As Object
Dim subject_ As String
Dim attach_ As String
Dim pWord As String

'Create Outlook
Set OutlookApp = CreateObject("Outlook.Application")

pWord = "rbs"
SendTo = "thevarajan_subramanin@astro.com.my"
fName = "Weekly Summary Report"

Application.DisplayAlerts = False


'Copy to New Sheet '
Sheets(fName).Copy
Set ws = ActiveSheet
With ws
    .Unprotect (pWord)
    With .Range("A1", .Range("A1").End(xlUp))
      .Copy
      .PasteSpecial Paste:=xlPasteFormats
      .PasteSpecial Paste:=xlPasteValues
    End With
    .Range("A30").Formula = "=hyperlink(""\\Poaabc04\regional programming\RBS Prime Data\RBS Productivity & KPI Measurement"",""For more details: Click here"")"
    .Range("A1").Select
End With

'Save Temp Copy'
Set wb = ActiveWorkbook
With wb
  .Sheets("Weekly Summary Report").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="rbs"
  .SaveAs Filename:="C:\" & fName & ".xls"
  .Close
End With

'Fill in Subject Details'
subject_ = fName & ".xls"
attach_ = "C:\" & fName & ".xls"

'Create the Email
Set MItem = OutlookApp.createitem(0)
With MItem
  .To = SendTo
  .Subject = subject_
  .attachments.Add (attach_)
  'Send the Email
  .Send
End With

'Clear Resources
Set MItem = Nothing
Set OutlookApp = Nothing
'Delete File
Kill Pathname:="C:\" & fName & ".xls"
Application.DisplayAlerts = True

End Sub

           
         

Open in New Window

Select All

Answer : Add-in aditional words in Excel File Name

I have made a few assumptions ... see how this looks:

Chris

                       
         
           
             1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:

           
           
             Sub SendEmail()
Dim wb As Workbook
Dim ws As Worksheet
Dim strShName As String
Dim fName As String
Dim SendTo As String
Dim OutlookApp As Object
Dim MItem As Object
Dim subject_ As String
Dim attach_ As String
Dim pWord As String
'Create Outlook
Set OutlookApp = CreateObject("Outlook.Application")
pWord = "rbs"
SendTo = "thevarajan_subramanin@astro.com.my"
strShName = "Weekly Summary Report"
Sheets(strShName).Copy
fName = strShName & "@" & ThisWorkbook.Sheets("Detail Task").Range("C2")
Application.DisplayAlerts = False
'Copy to New Sheet '
Set ws = ActiveSheet
With ws
    .Unprotect (pWord)
    With .Range("A1", .Range("A1").End(xlUp))
      .Copy
      .PasteSpecial Paste:=xlPasteFormats
      .PasteSpecial Paste:=xlPasteValues
    End With
    .Range("A30").Formula = "=hyperlink(""\\Poaabc04\regional programming\RBS Prime Data\RBS Productivity & KPI Measurement"",""For more details: Click here"")"
    .Range("A1").Select
End With
'Save Temp Copy'
Set wb = ActiveWorkbook
With wb
  .Sheets(strShName).Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="rbs"
  .SaveAs Filename:="C:\" & fName & ".xls"
  .Close
End With
'Fill in Subject Details'
subject_ = fName & ".xls"
attach_ = "C:\" & fName & ".xls"
'Create the Email
Set MItem = OutlookApp.createitem(0)
With MItem
  .To = SendTo
  .Subject = subject_
  .attachments.Add (attach_)
  'Send the Email
  .display
End With
'Clear Resources
Set MItem = Nothing
Set OutlookApp = Nothing
'Delete File
Kill Pathname:="C:\" & fName & ".xls"
Application.DisplayAlerts = True
End Sub
           
         

Open in New Window

Select All