amend code to extract .xls if not specified ob .xlsm if specified

howard

Well-known Member
Joined
Jun 26, 2006
Messages
6,589
Office Version
  1. 2021
Platform
  1. Windows
I have workbooks names in Col a on sheet1 that are .xls files if not specified
eg M_BR1 Sales (P). M_ERT Sales (P) Etc


I have specifiedthe .xlsm files

eg M_BR3 Sales (P).xslm




I have code below to create an email in outlook and to attach the sheet "summary", which works perfectly where the excel type is not specified. where the type .xlsm is specified , I get a run time error

The code that needs to be amended is as follows:

Code:
  s = "C:\Sales Reports" & rng.Value & ".xls"
    x = "C:\Sales Reports" & rng.Value & " summary" & ".xls"


See full code below

Code:
 Sub SendEmail()
    Dim OutlookApp As Object
    Dim mItem As Object
    Dim Cell As Range
    Dim Subj As String
    Dim EmailAddr As String
    Dim Body As String
    Dim Body1 As String
    
  
    
    '-------------------------------------------
    Dim s As String, wb As Workbook, ws As Worksheet, rng As Range, rng1 As Range, c As Range, LstRw As Long, x As String
    Application.DisplayAlerts = False
   
    
    Set rng = ActiveCell
    If rng.Column <> 1 Then
        MsgBox "You are not in the correct column"
        Exit Sub
    End If
    If rng.Value = "" Then
        MsgBox "Nothing selected"
        Exit Sub
    End If

    s = "C:\Sales Reports\" & rng.Value & ".xls"
    
    
    Set wb = Workbooks.Open(s)
    Set ws = wb.Sheets("summary")
    x = "C:\Sales Reports\" & rng.Value & " summary" & ".xls"
    ws.Copy
    ActiveWorkbook.SaveAs x
    ActiveWorkbook.Close
    wb.Close
    '----------------------------------------
    Set OutlookApp = CreateObject("Outlook.Application")
    EmailAddr = rng.Offset(, 1)
    Subj = rng & " -sales Report"
    
   
               
    Body = "Attached please find sales figures as well as prior year Sales as at  " & Format(Application.EoMonth(Date, -1), _
  "mmm yyyy") & " vs the Prior Year" & vbNewLine & vbNewLine
    Body = "Hi Guys" & vbNewLine & vbNewLine & Body
  Body = Body & "Regards" & vbNewLine & vbNewLine & "Howard"
    Set mItem = OutlookApp.createitem(0)

    With mItem
        .To = EmailAddr
        .Subject = Subj
             .Body = Body
        .attachments.Add x
        .display
        ' .send   'use this when you want to send.
    End With

ExitPoint:
    Set OLMsg = Nothing
    rng.Offset(, 2) = "Sent"
    
     rng.Offset(, 2).Font.Bold = True
     ActiveCell.Offset(1).Select
   

      
End Sub



It would be appreciated if someone could kindly amend my code
 
Last edited:

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
Hi there.
Try this:
Code:
If LCase(Right(Rng, 5)) <> ".xlsm" Then
    s = "C:\Sales Reports" & Rng.Value & ".xls"
    x = "C:\Sales Reports" & Rng.Value & " summary" & ".xls"
Else
    s = "C:\Sales Reports" & Rng.Value
    x = "C:\Sales Reports" & Left(Rng.Value, Len(Rng.Value) - 5) & " summary.xlsm"
End If
 
Upvote 0
Thanks for the help John


The code works perfectly for .xls files, but where the file is n .xlsm workbook, it comes up with a message "this extension cannot be used with this file type. change file extension in the file name ………..


The following code is highlighted


Code:
  ActiveWorkbook.SaveAs x


Kindly amend to accomodate .xlsm file types as well as .xls file types


your assistance in this regard is most appreciated
 
Upvote 0

Forum statistics

Threads
1,223,214
Messages
6,170,774
Members
452,353
Latest member
strainu

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