How I can replace "Range("A1:M35")" in below code with a range selected by the mouse?
Excel VBA macro send a selection of current workbook as attachment to an email
Sub Mail_to_recipients()
Dim OutApp As Object
Dim OutMail As Object
Dim myDataRng As Range
Dim cell As Range
Dim iCnt As Integer
Dim sMail_ids As String
Dim TempFilePath As String
Dim FileExt As String
Dim TempFileName As String
Dim FileFullPath As String
Dim FileFormat As Variant
Dim Wb1 As Workbook
Dim Wb2 As Workbook
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Wb1 = ThisWorkbook
Set Wb2 = Workbooks.Add(xlWBATWorksheet)
Wb1.ActiveSheet.Range("A1:M35").Copy Wb2.Sheets(1).Range("A1")
Wb2.Sheets(1).Name = Wb1.ActiveSheet.Name
'Below code will get the File Extension and
'the file format which we want to save the copy
'of the workbook with the active sheet.
With Wb2
If Val(Application.Version) < 12 Then
FileExt = ".xls": FileFormat = -4143
Else
Select Case Wb1.FileFormat
Case 51: FileExt = ".xlsx": FileFormat = 51
Case 52:
If .HasVBProject Then
FileExt = ".xlsm": FileFormat = 52
Else
FileExt = ".xlsx": FileFormat = 51
End If
Case 56: FileExt = ".xls": FileFormat = 56
Case Else: FileExt = ".xlsb": FileFormat = 50
End Select
End If
End With
'Save your workbook in your temp folder of your system
'below code gets the full path of the temporary folder
'in your system
TempFilePath = Environ$("temp") & "\"
'Now append a date and time stamp
'in your new file
TempFileName = Wb1.Name & "-" & Format(Now, "dd-mmm-yy h-mm-ss")
'Complete path of the file where it is saved
FileFullPath = TempFilePath & TempFileName & FileExt
'Now save your currect workbook at the above path
Wb2.SaveAs FileFullPath, FileFormat:=FileFormat
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set myDataRng = Wb1.ActiveSheet.Range("AJ5:AJ10" & Cells(Rows.Count, "AJ").End(xlUp).Row)
' Run a loop to extract email ids from the 2nd column.
For Each cell In myDataRng
If Trim(sMail_ids) = "" Then
sMail_ids = cell.Offset(1, 0).Value
Else
sMail_ids = sMail_ids & vbCrLf & ";" & cell.Offset(1, 0).Value
End If
Next cell
Set myDataRng = Nothing ' Clear the range.
On Error Resume Next
With OutMail
.To = sMail_ids
.CC = ""
.BCC = ""
.Subject = "Weekindeling week " & Range("K1")
.Attachments.Add FileFullPath
.Display
End With
On Error GoTo 0
'Since mail has been sent with the attachment
'Now close and delete the temp file from the
'temp folder
Wb2.Close SaveChanges:=False
Kill FileFullPath
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I have tried to replace the range with below code, but it doesn't work :(
Selection.Address(ReferenceStyle:=xlA1, _
RowAbsolute:=False, ColumnAbsolute:=False)
CodePudding user response:
Please, try replacing this code part:
Set Wb1 = ThisWorkbook
Set Wb2 = Workbooks.Add(xlWBATWorksheet)
Wb1.ActiveSheet.Range("A1:M35").Copy Wb2.Sheets(1).Range("A1")
with:
Dim rngC as Range, arrW() As Double, i As Long
Set Wb1 = ThisWorkbook: Set rngC = Selection
'place the column width in the arrW array:
ReDim arrW(1 To rng.Columns.Count)
For i = 1 To UBound(arrW)
arrW(i) = rngC.Columns(i).ColumnWidth
Next
Set Wb2 = Workbooks.Add(xlWBATWorksheet)
rngC.Copy Wb2.Sheets(1).Range("A1")
'adjust the column width according to arrW memorized columns width:
For i = 1 to UBound(arrW)
Wb2.Sheets(1).cells(1, i).EntireColumn.ColumnWidth = arrW(i)
Next i
The above suggestion works for a selection done before running the code. If you need to select a specific range during the code run, I can show you a solution, but you must state that...