Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Преобразовать формулы на листе в значения, затем прикрепить сам лист к новому сообщению в Outlook, Нужен макрос
 
#1
26.06.2020 18:49:02
Добрый день,

В рабочем файле есть два листа. На одном из них с названием "CMR-LT" есть формулы.
Нужно по нажатию кнопки (она на листе с именем CALC) преобразовать все формулы на листе "CMR-LT" в значения, затем вызвать Outlook и прикрепить этот преобразованный лист к окну нового сообщения.
При этом в subject-е письма должно автоматически прописываться название инвойса. (в ячейке B1 примера выделенно красным что именно должно прописываться)
Также из диспечера имен преобразованного листа должны удаляться все лишние именнованные диапазоны. Остаться должен лишь "Print Area".

Можно ли сделать такое макросом?
Если да, то буду признателен за помощь.
Структура рабочего файла в примере.

UPD: В сети разыскал макрос который преобразует формулы в значения и сохраняет лист по указанному пути.
При этом он нарушает исходное форматирование.
Изменено: memo - 26.06.2020 21:44:15
 
 
 
#2
27.06.2020 14:21:12
надо запустить макрос memo
Код
Sub memo1()
Worksheets("CMR-LT").UsedRange.Copy
Worksheets("CMR-LT").UsedRange.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End Sub


Sub memo2()
Dim IName As Name
For Each IName In ActiveWorkbook.Names
On Error Resume Next
If Not IName.Name Like "*Print_Area*" Then
IName.Delete
End If
Next IName
End Sub

Sub memo3()
Dim olApp As Object
Dim olEmail As Object

Set olApp = CreateObject("Outlook.Application")
Set olEmail = olApp.CreateItem(olMailItem)

ThisWorkbook.Sheets("CMR-LT").Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\файлик.xlsx"

     With olEmail
     
    .BodyFormat = 2
    
    .Subject = ThisWorkbook.Sheets("CALC").Range("B1").Value
    .Attachments.Add (ThisWorkbook.Path & "\файлик.xlsx")

    .Display
    End With
    ActiveWorkbook.Close SaveChanges:=True
    Kill ThisWorkbook.Path & "\файлик.xlsx"

End Sub


Sub memo()
memo1
memo2
memo3
End Sub
Изменено: pantel1987 - 27.06.2020 14:21:58
 
 
 
#3
27.06.2020 15:20:40
pantel1987,
Вы замечательно все поняли и сделали, спасибо!
Правда есть одно очень существенное но: именованные диапазоны должны удаляться у прикрепленного листа (у созданного файлика) а не у исходного.
Исходный лист должен оставаться без изменений.
Изменено: memo - 27.06.2020 17:17:22
 
 
 
#4
27.06.2020 18:15:41
Код
Sub memo()
Dim olApp As Object
Dim olEmail As Object
Dim IName As Name

Set olApp = CreateObject("Outlook.Application")
Set olEmail = olApp.CreateItem(olMailItem)
 
 
ThisWorkbook.Worksheets("CMR-LT").UsedRange.Copy
ThisWorkbook.Worksheets("CMR-LT").UsedRange.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
ThisWorkbook.Sheets("CMR-LT").Copy

For Each IName In ActiveWorkbook.Names
On Error Resume Next
If Not IName.Name Like "*Print_Area*" Then
IName.Delete
End If
Next IName

ActiveWorkbook.SaveAs ThisWorkbook.Path & "\файлик.xlsx"
 
     With olEmail
      
    .BodyFormat = 2
     
    .Subject = ThisWorkbook.Sheets("CALC").Range("B1").Value
    .Attachments.Add (ThisWorkbook.Path & "\файлик.xlsx")
 
    .Display
    End With
    ActiveWorkbook.Close SaveChanges:=True
    Kill ThisWorkbook.Path & "\файлик.xlsx"

 
End Sub
 
 
 
#5
27.06.2020 18:30:55
pantel1987,
С именованными теперь все хорошо, но после применения макроса на исходном листе все формулы тоже преобразовываются в значения.
 
 
 
#6
27.06.2020 18:33:33
Код
Sub memo()
Dim olApp As Object
Dim olEmail As Object
Dim IName As Name
 
Set olApp = CreateObject("Outlook.Application")
Set olEmail = olApp.CreateItem(olMailItem)
    
ThisWorkbook.Sheets("CMR-LT").Copy
 
For Each IName In ActiveWorkbook.Names
On Error Resume Next
If Not IName.Name Like "*Print_Area*" Then
IName.Delete
End If
Next IName

ActiveWorkbook.Worksheets("CMR-LT").UsedRange.Copy
ActiveWorkbook.Worksheets("CMR-LT").UsedRange.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
 
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\файлик.xlsx"
  
     With olEmail
       
    .BodyFormat = 2
      
    .Subject = ThisWorkbook.Sheets("CALC").Range("B1").Value
    .Attachments.Add (ThisWorkbook.Path & "\файлик.xlsx")
  
    .Display
    End With
    ActiveWorkbook.Close SaveChanges:=True
    Kill ThisWorkbook.Path & "\файлик.xlsx"
 
  
End Sub
 
 
 
#7
27.06.2020 19:00:58
pantel1987,
Великолепно. Теперь все работает как надо. Большое спасибо!
 
 
 
Страницы: 1
Наверх