Страницы: 1
RSS
Копирование отфильтрованного диапазона в новую книгу и отправка новой книги по почте (Outlook) определенному адресату.
 
Доброго дня всем!
Помогите с таким макросом:
Есть файл (например "Список деталей"). Сам список в столбце А (начинается с А2, в А1 заголовок "Список"), ячейки залиты разными цветами. Необходимо по кнопке отфильтровать список "Сортировка по цвету" - по критерию "нет заливки", далее скопировать отфильтрованный диапазон, открыть новую книгу Excel, вставить скопированное в столбец А (начать с ячейки например А1) и отправить эту новую книгу (как правило называется "Книга1) по электронной почте Microsoft Outlook на определенный адрес (всегда один и тот же).
Далее закрыть без сохранения новую книгу и с сохранением книгу со списком (при этом фильтр можно снять - удобно, но не сильно важно, можно просто сохранить). Последние пункты не критичны (про сохранение), но желательны).
Прошу прощения - пример выложить не могу - корпоративный интернет, скачать дает, а залить файл - нет, Вроде всё понятно написал.
Заранее благодарен всем за оказанную помощь.
 
evg_glaz,
Нужен пример файла
почему не хотите записать данный макрос?
Изменено: evgeniygeo - 20.09.2022 09:14:01
 
Вот часть списка, некоторые ячейки залиты желтым, зеленым и красным (в сообщении не видно), файл залить не представляется возможным.
Файлы всегда разные, списки тоже (от 5 до 400 строк), потому запись ничего внятного не дает. К тому же на отправке всё останавливается...

Список деталей
92656875
42415893
42415901
42415919
42415927
42415943
42416453
42416461
42412890
42414755
42414763
 
Цитата
evg_glaz написал:
файл залить не представляется возможным.
почему? Вы не можете даже сделать небольшой файл пример, чтобы тем, кто захочет решить Вашу задачу потратив свое время не пришлось его "лепить" самостоятельно?
Цитата
evg_glaz написал:
Файлы всегда разные, списки тоже (от 5 до 400 строк), потому запись ничего внятного не дает. К тому же на отправке всё останавливается...
так, стоп. Почему запись ничего не дает? Покажите пожалуйста, что у Вас получается в ходе записи?
С отправкой согласен, тут тупо нужно сделать один запрос в поисковую строку и взять первую ссылку: https://ru.extendoffice.com/documents/excel/1353-excel-send-workbook.html
 
evgeniygeo,
Код
Sub КОПИР_СПИСОК()
'
' КОПИР_СПИСОК Макрос
'

'
    ActiveSheet.Range("$A$3:$B$89").AutoFilter Field:=1, Operator:= _
        xlFilterNoFill
    Range("A4").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    ActiveWindow.SmallScroll Down:=-93
    ActiveSheet.Range("$A$3:$B$89").AutoFilter Field:=1
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\......... Список.xlsm" _
        , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End Sub
Вот что получается. Действия в новой книге не записываются. И диапазон фиксированный, а у меня всегда разный.
Цитата
Прошу прощения - пример выложить не могу - корпоративный интернет, скачать дает, а залить файл - нет, Вроде всё понятно написал.
Не дает выложить файл... Приношу извинения за доставляемые неудобства - с правилами ознакомлен, но...
 
evg_glaz,
ок, но Вы можете все немного изменить и фильтровать так:
Код
Sub Макрос2()
ActiveSheet.Range("A3:B10000").AutoFilter Field:=1, Operator:=xlFilterNoFill
Range("A3:B10000").Copy
End Sub

или так:
Код
Sub Макрос2()
ActiveSheet.Range("A3:B" & Cells(Rows.Count, "B").End(xlUp).Row).AutoFilter Field:=1, Operator:=xlFilterNoFill
Range("A3:B" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
End Sub

далее, чтобы создать новую книгу:
Код
Workbooks.Add
Изменено: evgeniygeo - 20.09.2022 10:52:46
 
Цитата
ок, но Вы можете все немного изменить и фильтровать так:
А как потом новую книгу открыть и отфильтрованный диапазон перенести?
 
evg_glaz,
например, так:
Код
Sub asasd()
ThisWorkbook.ActiveSheet.Range("A3:B" & ThisWorkbook.ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row).AutoFilter Field:=1, Operator:=xlFilterNoFill
ThisWorkbook.ActiveSheet.Range("A3:B" & ThisWorkbook.ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row).Copy
Workbooks.Add
ActiveSheet.Paste
End Sub
 
Код
Sub Отправить_список()
    Dim sFileName As String, sFolderPath As String, Rng As Range, wbTemp As Workbook
    Range("A1") = Date & " " & ThisWorkbook.Name
    If MsgBox("Сохранить диапазон в файл?", vbQuestion + vbYesNo, "Сохранение в файл") = vbNo Then Exit Sub
    With Worksheets("Лист1")
        'проверяем пуста ли ячейка A1 на Лист1
        If IsEmpty(.Range("A1")) Then
            MsgBox "Ячейка A1 на Лист1 пустая!", vbExclamation, "Внимание"
           Exit Sub
        End If
        'присваиваем диапазон переменной Rng
        ActiveSheet.Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row).AutoFilter Field:=1, Operator:=xlFilterNoFill
        Set Rng = .Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        'имя файла
        sFileName = .Range("A1") & ".xlsx"
    End With
    'имя папки куда сохранять
    sFolderPath = ThisWorkbook.Path & Application.PathSeparator
    'проверяем есть ли файл с таким же именем в папке
    If Dir(sFolderPath & sFileName) <> "" Then
        MsgBox "Файл с именем: '" & sFileName & "' уже есть в папке: " & sFolderPath, vbExclamation, "Внимание"
        Exit Sub
    End If
    'отключаем обновление экрана
    Application.ScreenUpdating = False
    'копируем диапазон из книги
    Rng.Copy
    'создаём новую книгу
    Set wbTemp = Workbooks.Add(1)
    With wbTemp.Sheets(1)
        .Cells(1).PasteSpecial xlPasteColumnWidths 'вставляем ширину столбцов
        .Cells(1).PasteSpecial xlPasteValues 'вставляем только значения
        .Cells(1).Select
    End With
    'сохраняем файл
    wbTemp.SaveAs sFolderPath & sFileName, 51  '51 - это формат XLSX
    'закрываем файл
    wbTemp.Close (False)
        
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    On Error Resume Next
    With OutlookMail
    .To = Range("B1").Value 'Адрес
    .CC = ""
    .BCC = ""
    .Subject = Range("A1").Value 'тема сообщения
    .Body = ""
    .Attachments.Add sFolderPath & sFileName, 51 'вложение
    .Send 'Display, если необходимо просмотреть сообщение,  Send -  отправлять без просмотра
End With
Set OutlookMail = Nothing
Set OutlookApp = Nothing
    'включаем обновление экрана
    Application.ScreenUpdating = True
    MsgBox "Книга сохранена!", vbExclamation, "Конец"
   ActiveSheet.Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).AutoFilter Field:=1
    Selection.AutoFilter
    Range("A1") = ""
    ActiveWorkbook.Save
    ActiveWorkbook.Close
End Sub

evgeniygeo, Спасибо!
Изломал голову, на примерах форума получилось)
Может что убавить/прибавить? Но всё работает как надо!
 
evgeniygeo, не подскажите, что нужно прописать в код, чтобы файл, в который скопирован диапазон не сохранялся (удалялся) после отправки?
Изменено: evg_glaz - 20.09.2022 15:33:27
 
evg_glaz,
так просто закройте ее без сохранения
Код
ActiveWorkbook.Close False
 
Цитата
evgeniygeo написал:
ActiveWorkbook.Close False
не соглашусь. Скорее надо после строки
Код
.Send 'Display, если необходимо просмотреть сообщение,  Send -  отправлять без просмотра

добавить такие:
Код
Kill sFolderPath & sFileName 'удаляем временный файл
DoEvents
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Дмитрий(The_Prist) Щербаков, Точно! Всё работает!
Дмитрий(The_Prist) Щербаков, evgeniygeo, СПАСИБО БОЛЬШОЕ!!!
 
Цитата
Дмитрий(The_Prist) Щербаков написал:
не соглашусь. Скорее надо после строки
согласен, но я вот изначально не понимаю, зачем временный файл куда-то сохранять если его в итоге все равно нужно удалить...
 
Цитата
evgeniygeo написал:
изначально не понимаю, зачем временный файл куда-то сохранять
потому что невозможно вложить в письмо не сохраненный файл.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Дмитрий(The_Prist) Щербаков,
даже не подумал, спасибо за разъяснения)))
Страницы: 1
Наверх