Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Пользователи » Валерий
Выбрать дату в календаре…Выбрать дату в календаре

Страницы: 1 2 След.
Отправка файла по выбору из папки, Макрос отправки файла по команде из Excel
 
#
10.04.2025 23:06:14
Aлeкceй,  
Ну он выбирает несколько файлов, но при этом вкладывает файлы по отдельности в два разных письма  
 
Перейти    
Отправка файла по выбору из папки, Макрос отправки файла по команде из Excel
 
#
10.04.2025 17:53:40
Дмитрий(The_Prist) Щербаков,

Спасибо, теперь прикрепляет и показывает,  но если в диалоговом окне выбора файла нажать отмена, то возникает ошибка.  
Ну и второстепенная ошибка, если в GetOpenFilename выбрать опцию True,  то несколько файлов не прикрепляет
Код
Sub SendFile()
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim fail
fail = Application.GetOpenFilename("All files(*.*),*.*", 1, "Выбрать файл", , False)  'True не работает!
' Создание нового экземпляра приложения Outlook
Set OutlookApp = CreateObject("Outlook.Application")
' Создание нового электронного письма
Set OutlookMail = OutlookApp.CreateItem(0)
' Определение параметров письма
With OutlookMail
 .Attachments.Add (fail)
 If VarType(fail) = vbBoolean Then
Exit Sub
End If
 'If .Show = 0 Then Exit Sub 'выход если отмена (тоже не работает)
 .To = "адрес_получателя"
 .Subject = "Тема_письма"
 .Body = "Текст_письма"
 .Display
End With

' Освобождение ресурсов
Set OutlookMail = Nothing
Set OutlookApp = Nothing
End Sub
 
Перейти    
Отправка файла по выбору из папки, Макрос отправки файла по команде из Excel
 
#
09.04.2025 19:51:06
Благодарю. Прочитаю
 
Перейти    
Отправка файла по выбору из папки, Макрос отправки файла по команде из Excel
 
#
09.04.2025 19:38:43
Добрый день!
Подскажите пожалуйста, что не так,  доходит до выбора файла из папки,  а после аутлук не открывается, письмо не создает и файл не прикрепляет.  
Код
Sub SendFile()
Dim OutlookApp As Object
Dim OutlookMail As Object
' Создание нового экземпляра приложения Outlook
Set OutlookApp = CreateObject("Outlook.Application")
' Создание нового электронного письма
Set OutlookMail = OutlookApp.CreateItem(0)
' Определение параметров письма
With OutlookMail
.To = "адрес_получателя"
' .CC = "адрес_с_копией"
' .BCC = "адрес_с_скрытой_копией"
.Subject = "Тема_письма"
.Body = "Текст_письма"
.Attachments.Add Application.GetOpenFilename
' .Send
End With
' Освобождение ресурсов
Set OutlookMail = Nothing
Set OutlookApp = Nothing
End Sub
 
Перейти    
Корректное и полное заполнение формы., применяется проверка данных и условия форматирования
 
#
05.12.2024 18:01:34
Добрый день!

Есть форма для планирования отпусков на год.  Часто сотрудники заполняют его не корректно или не полностью.
Подскажите пожалуйста, как можно добавить условие, чтобы к примеру файл можно было сохранить, только при условии если расписаны все дни отпуска и/или столбец F поменял цвет на зеленый.  
Может быть есть еще вариант, чтобы избежать некорретное заполнение. (желательно минимальное использование макросов)  
Изменено: Валерий - 05.12.2024 18:05:21
 
Перейти    
График отпусков, Из таблицы с несколькими интервалами и именами сделать с уникальными именами
 
#
04.06.2024 14:25:09
Делал раньше таблицу с отпусками, она конечно не совершенна и формула громоздка, возможно получится сократить.  
На основании таблицы с периодом отпусков,  в каледарь проставляет 1 - день отпуска + зелёная заливка через условное форматирование.
 
Перейти    
Не выключается экрана обновление, Экрана не выключается обновление
 
#
03.06.2024 17:20:05
Код
Option Explicit
'удаление столбца из всех файлов в папке
Sub Get_All_File_from_Folder()
    Dim sFolder As String, sFiles As String
    Dim wb As Workbook
    'диалог запроса выбора папки с файлами
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    'отключаем обновление экрана, чтобы наши действия не мелькали
   Application.ScreenUpdating = False
    sFiles = Dir(sFolder & "*.xls*")
    Do While sFiles <> ""
        'открываем книгу
        Set wb = Application.Workbooks.Open(sFolder & sFiles)
        'действия с файлом
        'удаление столбца I : N
        wb.Sheets(1).Range("I:N").Delete
        'Закрываем книгу с сохранением изменений
        wb.Close True 'если поставить False - книга будет закрыта без сохранения
        sFiles = Dir
    Loop
    'возвращаем ранее отключенное обновление экрана
   Application.ScreenUpdating = True
End Sub
Добрый день!
В коде прописано отключение обновления экрана, но он всё равно мелькает.   Подскажите где не точность, как исправить
 
Перейти    
Изменение положения и размера рисунка после вставки, Изменение положения и размера рисунка после вставки
 
#
30.11.2023 15:34:46
Дмитрий(The_Prist) Щербаков,
Благодарю за помошь!

просто у меня заработало изменение положения и размера, когда написал так:

Код
Windows("NAME.xlsx").Activate   
    Selection.ShapeRange.IncrementLeft -537.8571653543
    Selection.ShapeRange.IncrementTop -26.7857480315
    Selection.ShapeRange.ScaleWidth 0.9205716091, msoFalse, msoScaleFromTopLeft

Но и ваш способ тоже работает и даже без активации листа

Итоговый вариант:

Код
Sub Itog()
'макрос вставки итога в виде картинки из таблицы
     Dim fio As Variant
Dim list As Worksheet
Set list = ActiveSheet

    fio = ActiveSheet.Range("A2")
    Application.Workbooks("2023.xlsx").Activate
'фильтр по значению
    Sheets("ОКТЯБРЬ").Range("$B$2:$R$103").AutoFilter Field:=1, Criteria1:=fio
'выделение и копирование   
    Sheets("ОКТЯБРЬ").Range("$B$2:$R$103").Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
'вставка рисунка в активный лист  
    list.Pictures.Paste.Select
'изменение размера и положения   
    list.Shapes(list.Shapes.Count).ScaleWidth 0.919254124, msoFalse, msoScaleFromTopLeft
    list.Shapes(list.Shapes.Count).IncrementLeft -537.8571653543
    list.Shapes(list.Shapes.Count).IncrementTop -26.7857480315

End Sub

Изменено: Валерий - 30.11.2023 16:06:16
 
Перейти    
Изменение положения и размера рисунка после вставки, Изменение положения и размера рисунка после вставки
 
#
30.11.2023 15:21:11
Дмитрий(The_Prist) Щербаков,

а можно будет как то использовать для активации?
Код
Windows(имя_листа).Activate      
Но прим этом имя листа каждый раз разное,  имя_листа = это всегда лист в котором запускается макрос.

??
Изменено: Валерий - 30.11.2023 15:21:48
 
Перейти    
Изменение положения и размера рисунка после вставки, Изменение положения и размера рисунка после вставки
 
#
30.11.2023 13:51:07
Дмитрий(The_Prist) Щербаков,
Разные
Лист "ОКТЯБРЬ"  в файле 2023.xlsx  
Запуск макроса происходит в другой книге.

Макрос работает до момента изменения размера.  
Картинка вставляется в активный лист и после вставки остается активированной, но далее изменение положения и размера не работает.  
 
Перейти    
Изменение положения и размера рисунка после вставки, Изменение положения и размера рисунка после вставки
 
#
30.11.2023 11:26:44
Добрый день!

Нужна помощь в коде.
Макрос: в активном листе берется значение из ячейки А2
далее в файле 2023.xlsx  на листе "ОКТЯБРЬ" фильтруется по значению из А2,
результат выделятся,  в выделеном выбирается только видимые ячеки,
видимые ячейки копируются и вставляются на активном листе в виде картинки (картинка после вставки остается выделенной)
Весь код:
Код
Sub Itog()
'макрос вставки итога в виде картинки из таблицы
     Dim fio As Variant
Dim list As Worksheet
Set list = ActiveSheet

    fio = ActiveSheet.Range("A2")
    Application.Workbooks("2023.xlsx").Activate
'фильтр по значению
    Sheets("ОКТЯБРЬ").Range("$B$2:$R$103").AutoFilter Field:=1, Criteria1:=fio
'выделение и копирование   
    Sheets("ОКТЯБРЬ").Range("$B$2:$R$103").Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
'вставка рисунка в активный лист  
    list.Pictures.Paste.Select
'изменение размера и положения   
    Selection.ShapeRange.ScaleWidth 0.919254124, msoFalse, msoScaleFromTopLeft
       
End Sub

Но макрос полностью не выполняется, вставляет рисунок и далее ругается на строку:     (но если выделить рисунок и запустить эту строку отдельно, то изменение размера и положения работает)
Код
 Selection.ShapeRange.ScaleWidth 0.919254124, msoFalse, msoScaleFromTopLeft

подскажите пожалуйста, как поправить


(ps  редко, но макрос бывает спотыкается на строке  
Код
list.Pictures.Paste.Select
закономерности не понял, на одном и том же листе, то нормально работает, а иногда после ошибки, остановки и повоторного запуска)
Изменено: Валерий - 30.11.2023 12:48:16
 
Перейти    
Формулы считают и ссылаются на значения из другого файла, которого нет, Есть документ с формулами и связями на другие документы, который при копировании на другой компьютер, ссылается на документы, которых нет, и рассчитывает формулы
 
#
19.10.2022 14:24:23
На другом компьютере есть доступ к Z:\Rent\Сводная\  
отключите его от сети и проверьте
 
Перейти    
Формула вывода фамилий из графика отпусков по месяцам
 
#
18.10.2022 12:54:36
Цитата
написал:
=ФИЛЬТР($B$3:$B$5;C3:C5="*")
у меня почему-то нет такой функции.  Excel2019
Изменено: Валерий - 18.10.2022 12:55:09
 
Перейти    
Формула вывода фамилий из графика отпусков по месяцам
 
#
18.10.2022 11:04:51
Всем добрый день!
Не стал сорздавать новую тему, и возможно пример будет полезен автору данной темы.  Помогите пожалуйста сократить формулу или заменить на иную чтобы в таблице с отпусками проставлялся день отпуска, а подтягивается он из вкладки "Список отпусков".    На листе Февраль в ячейках я писал когда то давно формулу, но она очень грамоздкая:
Код
 =ЕСЛИ(E$2>=ИНДЕКС('Список отпусков'!$H$11:$H$23;ПОИСКПОЗ($B4;'Список отпусков'!$C$11:$C$23;0));ЕСЛИ(E$2<=ИНДЕКС('Список отпусков'!$I$11:$I$23;ПОИСКПОЗ($B4;'Список отпусков'!$C$11:$C$23;0));1;ЕСЛИ(E$2>=ИНДЕКС('Список отпусков'!$H$11:$H$23;ПОИСКПОЗ($B4;'Список отпусков'!$C$11:$C$23;0)+1);ЕСЛИ(E$2<=ИНДЕКС('Список отпусков'!$I$11:$I$23;ПОИСКПОЗ($B4;'Список отпусков'!$C$11:$C$23;0)+1);1;ЕСЛИ(E$2>=ИНДЕКС('Список отпусков'!$H$11:$H$23;ПОИСКПОЗ($B4;'Список отпусков'!$C$11:$C$23;0)+2);ЕСЛИ(E$2<=ИНДЕКС('Список отпусков'!$I$11:$I$23;ПОИСКПОЗ($B4;'Список отпусков'!$C$11:$C$23;0)+2);1;ЕСЛИ(E$2>=ИНДЕКС('Список отпусков'!$H$11:$H$23;ПОИСКПОЗ($B4;'Список отпусков'!$C$11:$C$23;0)+3);ЕСЛИ(E$2<=ИНДЕКС('Список отпусков'!$I$11:$I$23;ПОИСКПОЗ($B4;'Список отпусков'!$C$11:$C$23;0)+3);1;ЕСЛИ(E$2>=ИНДЕКС('Список отпусков'!$H$11:$H$23;ПОИСКПОЗ($B4;'Список отпусков'!$C$11:$C$23;0)+4);ЕСЛИ(E$2<=ИНДЕКС('Список отпусков'!$I$11:$I$23;ПОИСКПОЗ($B4;'Список отпусков'!$C$11:$C$23;0)+4);1;"");""));""));""));""));"")
 
Перейти    
перенос строк в создаваемом письме Outlook, Перенос текстовых строк при создании письма Outlook
 
#
27.09.2022 11:57:06
Благодарю!  Всем хорошего дня!
 
Перейти    
перенос строк в создаваемом письме Outlook, Перенос текстовых строк при создании письма Outlook
 
#
27.09.2022 10:34:33
БМВ,   Почему-то вместо текста в письмо ставит просто 0  
Код
SM.HTMLBody = "Расчетная таблица за Август" < BR > "новый строки"
Изменено: Валерий - 27.09.2022 10:39:17
 
Перейти    
перенос строк в создаваемом письме Outlook, Перенос текстовых строк при создании письма Outlook
 
#
26.09.2022 22:37:31
Код
SM.HTMLBody = "Текст1" & vbNewLine & "Текст2" & SM.HTMLBody

 создается письмо с заданными значениями Кому, Тема и Текст письма,   подскажите пожалуйста, как перенести часть текста письма на новыую строку.   В коде для примера выше, текст просто идет следующим.
Изменено: Валерий - 26.09.2022 22:38:02
 
Перейти    
Вставка из буфера как изображение, Макрос вставки из буфера как картинки
 
#
26.10.2021 09:38:02
Есть.  Скопрированные ячейки вставляет в виде картинки. Но с этой строкой была ошибка.  
 
Перейти    
Макрос не подставляет имя файла при сохранении.
 
#
25.10.2021 21:47:11
Дмитрий(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
 
Перейти    
Вставка из буфера как изображение, Макрос вставки из буфера как картинки
 
#
25.10.2021 18:10:22
Да, удалил без неё работает.  Зачем то её макрорекордер вписал.  
 
Перейти    
Вставка из буфера как изображение, Макрос вставки из буфера как картинки
 
#
25.10.2021 16:54:36
Добьрый день!
Подскажите,  есть макрос вставки, предварительно выделенных и скопированных ячеек из буфера в виде изображения
Код
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
 
Перейти    
Макрос не подставляет имя файла при сохранении.
 
#
13.10.2021 20:34:30
Цитата
Дмитрий(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
 
Перейти    
Макрос не подставляет имя файла при сохранении.
 
#
12.10.2021 15:11:19
sokol92, работает, благодарю!

Дмитрий(The_Prist) Щербаков,  перечитаю,  но отстуствие / наличие точки никак не повлияло.  
Изменено: Валерий - 12.10.2021 15:24:41
 
Перейти    
Макрос не подставляет имя файла при сохранении.
 
#
12.10.2021 14:23:43
Добрый день!
Подскажите пожалуйста,  после перехода на 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
 
Перейти    
Сохранение файла с выбором директории
 
#
08.10.2021 18:49:45
Код
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
 
Перейти    
Сохранение файла с выбором директории
 
#
21.09.2021 22:28:18
bigorq,   нет конечно)    просто логику пытаюсь понять, в начале в переменную записано "как сохранять",  а потом написано "сохраняй так как написано в переменной".  

почему просто нельзя выполнить сразу, "сохраняй так как написал".  
Изменено: Валерий - 21.09.2021 22:29:07
 
Перейти    
Сохранение файла с выбором директории
 
#
21.09.2021 22:06:25
bigorq,  спасибо,  это понял.       а строка .SaveAs sAttachment  что выполняет?
Изменено: Валерий - 21.09.2021 22:06:46
 
Перейти    
Сохранение файла с выбором директории
 
#
21.09.2021 21:48:32
только если не сложно  подскажите в чем была разница.  я к сожалению пока не понимаю что дает команда 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
 
Перейти    
Сохранение файла с выбором директории
 
#
21.09.2021 21:42:51
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 при использовании функции еслиошибка?
 
#
21.09.2021 20:12:08
можно попробовать условия через И
Код
=(ЕСЛИОШИБКА(ЕСЛИ(И(условие1;условие2);(значение если истина;"значение если ложь");"значение если ошибка"))
Изменено: vikttur - 21.09.2021 22:00:33
 
Перейти    
Страницы: 1 2 След.
Наверх