Выбрать дату в календареВыбрать дату в календаре

Страницы: 1
Вставка из буфера как изображение, Макрос вставки из буфера как картинки
 
Есть.  Скопрированные ячейки вставляет в виде картинки. Но с этой строкой была ошибка.  
Макрос не подставляет имя файла при сохранении.
 
Дмитрий(The_Prist) Щербаков,

Благодарю за помощь.  
 крутил вертел я тот макрос, ничего не получалось. То выбираешь файл куда сохранить, а сохраняет всеравно не туда.  Сделал, сохраняет куда покажешь, но тогда в письмо его не прикрепляет.  вообщем провозился зря,  надо изучать всё полностью с азов.

Но наконец-то додел я макрос, именно тот который был у меня изначально
Он короче в два раза! и намного проще чем все ранее предложенные портянки с сохранением листа в отдельну книгу,   причем всё гораздо легче,  сохранить лист в отдельную книгу можно и без переменных, а также не нужна проверка открыт ли уже Outlook или нет,  если нет, он запустится.  В итоге всё работает,  сохраняет как надо, куда надо и с нужным именем. Письмо создает, файл прикрепляет.      Кому необоходимо пользуйтесь.
Код
Sub Save_and_Mail()
With Application.FileDialog(msoFileDialogSaveAs)
.InitialFileName = ActiveWorkbook.Path & "\" & ActiveWorkbook.ActiveSheet.Name
If .Show = 0 Then Exit Sub
ActiveWorkbook.ActiveSheet.Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=.SelectedItems(1)
Application.DisplayAlerts = True
End With

Dim OutlookApp As Object, SM As Object
 Set OutlookApp = CreateObject("Outlook.Application")
 Set SM = OutlookApp.CreateItem(olMailItem)
 'SM.SentOnBehalfOfName = "mail@example.ru" 'Поле "От", если нужен другой отправитель
 SM.To = Range("A3").Value 'адрес получателя
 SM.Subject = ActiveSheet.Name 'тема сообщения
 On Error Resume Next
 SM.Body = "Текст Письма planetaexcel"
 SM.Attachments.Add ActiveWorkbook.Path & "\" & ActiveWorkbook.Name 'Адрес вложения
 SM.Display
 Set SM = Nothing
 Set OutlookApp = Nothing
End Sub


Изменено: Валерий - 25.10.2021 22:01:11
Вставка из буфера как изображение, Макрос вставки из буфера как картинки
 
Да, удалил без неё работает.  Зачем то её макрорекордер вписал.  
Вставка из буфера как изображение, Макрос вставки из буфера как картинки
 
Добьрый день!
Подскажите,  есть макрос вставки, предварительно выделенных и скопированных ячеек из буфера в виде изображения
Код
Sub Макрос3()
'
' Макрос3 Макрос
'
' Сочетание клавиш: Ctrl+f
'
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.Pictures.Paste.Select
    ActiveSheet.Shapes.Range(Array("Picture 3")).Select
End Sub

Макрос выполняетя, но по итогу ругается на строку:
Код
ActiveSheet.Shapes.Range(Array("Picture 3")).Select
Изменено: Валерий - 25.10.2021 21:27:44
Макрос не подставляет имя файла при сохранении.
 
Цитата
Дмитрий(The_Prist) Щербаков написал:
Потому что уверен, что где-то ранее в коде используется On Error Resume Next
Да используется, так как вы и написали ранее этот код, возможно его можно сократить, но я в нем координально ничего не менял.
Код
Attribute VB_Name = "Module4"

Sub EXP() 'Макрос сохранения листа в новую книгу и отправки через Outlook
    Dim objOutlookApp As Object, objMail As Object
    Dim wb As Workbook
    Dim sAttachment As String
  
    Application.ScreenUpdating = False
    On Error Resume Next
    'пробуем подключиться к Outlook, если он уже открыт
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear 'Outlook закрыт, очищаем ошибку
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
 
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
     
    Application.DisplayAlerts = False
    Set wb = ActiveWorkbook
    sAttachment = wb.Path & "\" & ActiveSheet.Name & ".xlsx"

    ActiveSheet.Copy
    With ActiveWorkbook
    .sToSavePath = Application.GetSaveAsFilename(InitialFileName:=sAttachment, fileFilter:="Excel book(*.xlsx), *.xlsx")
        .SaveAs sAttachment, xlOpenXMLWorkbook
        .Close False
    End With
    Application.DisplayAlerts = True
    'создаем сообщение
    With objMail
        .To = Range("A3").Value 'адрес получателя
        .Subject = ActiveSheet.Name 'тема сообщения
        .Body = "Текст письма..."
        'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
        If sAttachment <> "" Then
            If Dir(sAttachment, 16) <> "" Then
                .Attachments.Add sAttachment 'просто вложение
            End If
        End If
        .Display 'если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With
  
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub


Изменено: Валерий - 13.10.2021 20:36:42
Макрос не подставляет имя файла при сохранении.
 
sokol92, работает, благодарю!

Дмитрий(The_Prist) Щербаков,  перечитаю,  но отстуствие / наличие точки никак не повлияло.  
Изменено: Валерий - 12.10.2021 15:24:41
Макрос не подставляет имя файла при сохранении.
 
Добрый день!
Подскажите пожалуйста,  после перехода на Excel 2019 / Windows 10,   макрос перестал  в диалоговое окно сохранения файла автоматически подставлять имя файла, исходя из названия листа.   в чем может быть дело?
часть кода, относящегося к сохранению файла
Код
 Set wb = ActiveWorkbook
    sAttachment = Application.GetSaveAsFilename(InitialFileName:=wb.Path & "\" & ActiveSheet.Name & ".xlsx")
    ActiveSheet.Copy
    With ActiveWorkbook
        .sToSavePath = Application.GetSaveAsFilename(InitialFileName:=sAttachment)
        .SaveAs sAttachment, xlOpenXMLWorkbook
        .Close False
    End With
    Application.DisplayAlerts = True

И пробовал прописать так:
Код
 .sToSavePath = Application.GetSaveAsFilename(InitialFileName:=wb.Path & "\" & ActiveSheet.Name & ".xlsx") 
 но всё равно не работает.
Изменено: Валерий - 12.10.2021 14:45:13
Сохранение файла с выбором директории
 
Код
Sub EXP() 'Макрос сохранения листа и отправки

    Dim objOutlookApp As Object, objMail As Object
    Dim wb As Workbook
    Dim sAttachment As String
  
    Application.ScreenUpdating = False
    On Error Resume Next
    'пробуем подключиться к Outlook, если он уже открыт
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear 'Outlook закрыт, очищаем ошибку
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
 
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
     
    Application.DisplayAlerts = False
    Set wb = ActiveWorkbook
    sAttachment = Application.GetSaveAsFilename(InitialFileName:=wb.Path & "\" & ActiveSheet.Name & ".xlsx")
    ActiveSheet.Copy
    With ActiveWorkbook
        .sToSavePath = Application.GetSaveAsFilename(InitialFileName:=sAttachment)
        .SaveAs sAttachment, xlOpenXMLWorkbook
        .Close False
    End With
    Application.DisplayAlerts = True
    'создаем сообщение
    With objMail
        .To = Range("A3").Value 'адрес получателя
        .Subject = ActiveSheet.Name 'тема сообщения
        'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
        If sAttachment <> "" Then
            If Dir(sAttachment, 16) <> "" Then
                .Attachments.Add sAttachment 'просто вложение
            End If
        End If
        .Display 'если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With
  
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

Добрый день!
Подскажите пожалуйста,  после перехода на Excel 2019 / Windows 10,   макрос перестал  в диалоговое окно сохранения файла автоматически подставлять имя файла, исходя из названия листа.   в чем может быть дело?
И пробовал прописть так:
Код
 sAttachment = Application.GetSaveAsFilename(InitialFileName:=wb.Path & "\" & ActiveSheet.Name & ".xlsx")
  но всё равно не работает.
Изменено: Валерий - 08.10.2021 18:54:26
Сохранение файла с выбором директории
 
bigorq,   нет конечно)    просто логику пытаюсь понять, в начале в переменную записано "как сохранять",  а потом написано "сохраняй так как написано в переменной".  

почему просто нельзя выполнить сразу, "сохраняй так как написал".  
Изменено: Валерий - 21.09.2021 22:29:07
Сохранение файла с выбором директории
 
bigorq,  спасибо,  это понял.       а строка .SaveAs sAttachment  что выполняет?
Изменено: Валерий - 21.09.2021 22:06:46
Сохранение файла с выбором директории
 
только если не сложно  подскажите в чем была разница.  я к сожалению пока не понимаю что дает команда sAttachment  в первом и втором случае
Код
sAttachment = wb.Path & "\" & ActiveSheet.Name & ".xlsx"    
ActiveSheet.Copy
    With ActiveWorkbook
 .sToSave = Application.GetSaveAsFilename(InitialFileName:=wb.Path & "\" & ActiveSheet.Name & ".xlsx")
        .SaveAs sAttachment, xlOpenXMLWorkbook

и
Код
sAttachment = Application.GetSaveAsFilename(InitialFileName:=wb.Path & "\" & ActiveSheet.Name & ".xlsx")    
ActiveSheet.Copy
    With ActiveWorkbook
        .SaveAs sAttachment, xlOpenXMLWorkbook
Изменено: Валерий - 21.09.2021 21:52:25
Сохранение файла с выбором директории
 
bigorq,
Благодарю за ответ.  
Я поправил код,  теперь работает как надо
Код
Sub EXP() 'Макрос сохранения листа и отправки

    Dim objOutlookApp As Object, objMail As Object
    Dim wb As Workbook
    Dim sAttachment As String
  
    Application.ScreenUpdating = False
    On Error Resume Next
    'пробуем подключиться к Outlook, если он уже открыт
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear 'Outlook закрыт, очищаем ошибку
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
 
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
     
    Application.DisplayAlerts = False
    Set wb = ActiveWorkbook
    sAttachment = Application.GetSaveAsFilename(InitialFileName:=wb.Path & "\" & ActiveSheet.Name & ".xlsx")
    ActiveSheet.Copy
    With ActiveWorkbook
        .SaveAs sAttachment, xlOpenXMLWorkbook
        .Close False
    End With
    Application.DisplayAlerts = True
    'создаем сообщение
    With objMail
        .To = Range("A3").Value 'адрес получателя
        .Subject = ActiveSheet.Name 'тема сообщения
        'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
        If sAttachment <> "" Then
            If Dir(sAttachment, 16) <> "" Then
                .Attachments.Add sAttachment 'просто вложение
            End If
        End If
        .Display 'если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With
  
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

в строке 22 было прописано сохранять в текущую папку.  добавил туда диалоговое окно сохранять как и тогда заработало.  строку 25 удалил.  
Изменено: Валерий - 21.09.2021 21:46:15
как избавиться от 0 при использовании функции еслиошибка?
 
можно попробовать условия через И
Код
=(ЕСЛИОШИБКА(ЕСЛИ(И(условие1;условие2);(значение если истина;"значение если ложь");"значение если ошибка"))
Изменено: vikttur - 21.09.2021 22:00:33
Сохранение файла с выбором директории
 
Подскажите пожалуйста по коду,
макрос выделяет лист в отдельную книгу, сохраняет её и отправляет через Outlook,  
но сохранение работает некорректно, а именно:  дает выбрать папку куда сохранить файл с листом, но после выбора всё равно сохранение файла происходит в папку где находится начальная книга
Код
Sub EXP() 'Макрос сохранения листа и отправки

    Dim objOutlookApp As Object, objMail As Object
    Dim wb As Workbook
    Dim sAttachment As String
  
    Application.ScreenUpdating = False
    On Error Resume Next
    'пробуем подключиться к Outlook, если он уже открыт
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear 'Outlook закрыт, очищаем ошибку
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
 
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
     
    Application.DisplayAlerts = False
    Set wb = ActiveWorkbook
    sAttachment = wb.Path & "\" & ActiveSheet.Name & ".xlsx"
    ActiveSheet.Copy
    With ActiveWorkbook
 .sToSave = Application.GetSaveAsFilename(InitialFileName:=wb.Path & "\" & ActiveSheet.Name & ".xlsx")
        .SaveAs sAttachment, xlOpenXMLWorkbook
        .Close False
    End With
    Application.DisplayAlerts = True
    'создаем сообщение
    With objMail
        .To = Range("A3").Value 'адрес получателя
        .Subject = ActiveSheet.Name 'тема сообщения
        'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
        If sAttachment <> "" Then
            If Dir(sAttachment, 16) <> "" Then
                .Attachments.Add sAttachment 'просто вложение
            End If
        End If
        .Display 'если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With
  
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub
что то не так со строками  25,  26  
Изменено: vikttur - 21.09.2021 20:22:24
Необходимо отправлять сохранённый файл через Outlook, прикрепление файла в письмо для отправки через Outlook
 
Дмитрий(The_Prist) Щербаков,

Очень признателен Вам за помощь!  Макрос работает.  Буду дальше ещё изучать с азов.   У меня уже был написан подобный макрос, я его также по отдельности с форума составлял,  сначала сохранение листа,  отдельно макрос отправка письма,  потом всё вместе.  Только код был значительно покороче без проверки запущен ли Outlook и существует файл или нет.  Но пока был в отпуске, айтишники на работе всё снесли, в том числе записи с сылками на сайты где чего я для себя выстаскивал. А я уже не помню, полтора года прошло.  Еще раз благодарю!
Необходимо отправлять сохранённый файл через Outlook, прикрепление файла в письмо для отправки через Outlook
 
Дмитрий(The_Prist) Щербаков,
Читал конечно,   сижу разбираюсь,  пытаюсь часть моего макроса соединять с той партянкой которая там выложена, у себя править, (чтобы сначала лист сохранялся и в письмо вкладывался)  в итоге  ошибка и дальше ничего не идет.    Да понятно что, просто взять начало моего макроса и после него тупо вставить макрос отправки письма, ничего не выйдет.   Может для опытного человека это выглядит всё элементарно, когда в голове выстроена структура что за чем идет, какая команда,    я же в этом не силён,  некоторые строки зачем нужны мне не понятно.  

Да даже к примеру взять этот код который уже написан,  мне не понятно почему перед некторыми командами (строками) есть . точка,  а в других нет,  а если её убрать, работать не будет.  И вот пишешь этот код, думаешь ну вроде всё верно, а нифига не работает,  а может не работает потому что точку не поставил?  так весь день.
Код
.SaveAs wb.Path & "\" & .ActiveSheet.Name & ".xlsx", xlOpenXMLWorkbook
    sAttachment = wb.Path & "\" & .ActiveSheet.Name & ".xlsx"
    ActiveWorkbook.SendMail Recipients:="new@adres.ru", Subject:="Тема письма"
    .Close False
Изменено: Валерий - 21.09.2021 16:11:50
Необходимо отправлять сохранённый файл через Outlook, прикрепление файла в письмо для отправки через Outlook
 
Удалось это сделать таким образом.
Копирование листа в новую книгу,  сохранение, отправка вложением
Код
Sub Save_And_Send_Sheet()
     Application.DisplayAlerts = False
    Set wb = ActiveWorkbook
    ActiveSheet.Copy
    With ActiveWorkbook
     
    .SaveAs wb.Path & "\" & .ActiveSheet.Name & ".xlsx", xlOpenXMLWorkbook
    sAttachment = wb.Path & "\" & .ActiveSheet.Name & ".xlsx"
    ActiveWorkbook.SendMail Recipients:="new@adres.ru", Subject:="Тема письма"
    .Close False
        End With
     Application.DisplayAlerts = True
       
    
End Sub

Но отправляется всё автоматически без открытия Outlook.       Необоходимо чтобы открывалась форма Outlook с вложенным файлом, заполненным с адресом и темой.   (Нужно для того, чтобы можно было в тексте письма  дополнить или отредактировать сообщение, а потом уже отправить.)
Изменено: Валерий - 21.09.2021 15:45:05
Необходимо отправлять сохранённый файл через Outlook, прикрепление файла в письмо для отправки через Outlook
 
Цитата
Дмитрий(The_Prist) Щербаков написал: Вы не знаете куда сохранили книгу?
Благодарю за ответ.
Просто путь сохранения файла каждый новый месяц меняется.
Изменено: vikttur - 21.09.2021 13:21:03
Необходимо отправлять сохранённый файл через Outlook, прикрепление файла в письмо для отправки через Outlook
 
Дмитрий(The_Prist) Щербаков, я пытался там разобраться, но там примеры с указанием конкретного пути к файлу на диске,  а не к сохранённому после выделения листа в отдельную книгу  
Изменено: vikttur - 21.09.2021 13:20:24
Необходимо отправлять сохранённый файл через Outlook, прикрепление файла в письмо для отправки через Outlook
 
Подскажите пожалуйста рашение,  макрос сохраняет активный лист в отдельную книгу,   далее необходимо эту книгу вложить в письмо Outlook,  отправка письма уже вручную.   но у меня здесь получается отправка исходной книги, причем без открытия окна Outlook
Код
Sub SaveSheet()
     Application.DisplayAlerts = False
    Set wb = ActiveWorkbook
    ActiveSheet.Copy
    With ActiveWorkbook
     
    .SaveAs wb.Path & "\" & .ActiveSheet.Name & ".xlsx", xlOpenXMLWorkbook
    .Close False
        End With
    ActiveWorkbook.SendMail Recipients:="new@adres.ru", Subject:="Тема письма"
    Application.DisplayAlerts = True
       
    
End Sub
Изменено: Валерий - 21.09.2021 13:01:33
Копирование листа в отдельную книгу
 
JayBhagavan,  
Спс.   поправил таким образом
Код
Sub SaveSheet()
     Application.DisplayAlerts = False
    Set wb = ActiveWorkbook
    ActiveSheet.Copy
    With ActiveWorkbook
     
    .SaveAs wb.Path & "\" & .ActiveSheet.Name & ".xlsx", xlOpenXMLWorkbook
    .Close False
        End With
    Application.DisplayAlerts = True
End Sub
Изменено: Валерий - 21.09.2021 10:46:21
Копирование листа в отдельную книгу
 
JayBhagavan,
Благодарю!   Подскажите пожалуйста, как прописать чтобы файл с листом сохранялся в ту же папку что и исходная книга?
Копирование листа в отдельную книгу
 
JayBhagavan, благодарю за помощь.    
Где то ошибка,  код присваивает исходному файлу с книгой, имя активного листа,  а активный лист, который создан в новой книге становится с именем Книга1

P.S.
Посмотрите пожалуйста, всё ли верно или есть что доработать или убрать:
(я в этом не профи, не пойму зачем нужны команды Application.DisplayAlerts)
Код
Private Sub CopySheet()
    Application.DisplayAlerts = False
    ActiveSheet.Copy
    With ActiveWorkbook
         .SaveAs .ActiveSheet.Name & ".xlsx", xlOpenXMLWorkbook
         .Close False
    End With
    Application.DisplayAlerts = True
End Sub
Изменено: Валерий - 21.09.2021 01:48:23
Копирование листа в отдельную книгу
 
Юрий М, извиняюсь, поправил,  тему к сожалению не изменить
Копирование листа в отдельную книгу
 
Приветствую всех!

Помогите пожалуйста, был написан макрос, но к сожалению теперь утерян :
Сохраниение активного листа в новую книгу, в папку где находится исходный файл,   имя файла = название листа

Сейчас есть только начало:
Код
Sub SohrList22()
Dim CurrentWin As Window
Dim VremWin As Window
Set CurrentWin = ActiveWindow
Set VremWin = ActiveWorkbook.NewWindow
CurrentWin.ActiveSheet.Copy
VremWin.Close
Path = ThisWorkbook.Path & "\"
ThisWorkbook.SaveAs (Path & ActiveSheet.Name)
End Sub
макрос создает файл с листом, но не берет название и не сохраняет
Изменено: vikttur - 21.09.2021 00:03:13
Страницы: 1
Наверх