Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
VBA рассылка данных отдельного листа как значение или в формате XPS, в каком виде лучше "выдернуть" лист из файла для дальнейшей рассылки?
 
#1
07.04.2015 00:56:31
Доброй ночи!!
Я добросовестный участник форума.. и прежде чем открывать тему...Внимательно 2 дня листала форум..Но так и не смогла решить до конца свою проблему. Не откажите в помощи.
Суть проблемы. Есть файл
лист 1 - исходные данные
лист сводная - на базе исходных данных строится сводная таблица
лист 2-27 - это исходная таблица разбрасывается по листам через Параметры сводной таблицы \ Отобразить страницы фильтра отчета

Дальнейшая цель - это рассылка каждого листа своему адресату (знаю, что тема избитая)
Имеется макрос, который формирует каждый лист в отдельный файл (в формате .xls)
Код
Sub SplitSheets2()
    Dim s As Worksheet
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    For Each s In wb.Worksheets                                
        s.Copy                                                 
        ActiveWorkbook.SaveAs wb.Path & "" & s.Name & ".xlsx"  
        ActiveWorkbook.Close False              
    Next
   End Sub

Посоветуйте как лучше поступить:
а) возможно ли доработать макрос (выше), чтобы он каждый лист сохранял как значение в отдельный файл (без потери в форматировании)
б) доработать макрос ниже, чтобы он все листы ПООЧЕРЕДИ сохранял в формате XPS в отдельные файлы
Код
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypeXPS, Filename:= _
     "C:\Договоры\Book1.xps", Quality:=xlQualityStandard, _
     IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:= False

Далее планирую использовать макрос для рассылки полученных файлов через OutLook адресатам
Заранее спасибо.
P.S. все макросы с Вашего сайта)
 
 
 
#2
07.04.2015 02:19:37
Доброе время суток
объект Worksheet имеет точно такой же метод ExportAsFixedFormat. Так что поменяйте код первого макроса для экспорта
Код
s.ExportAsFixedFormat Type:=xlTypeXPS, Filename:=wb.Path & "\" & s.Name & ".xps", _
Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:= False

Успехов
 
 
 
#3
07.04.2015 08:42:59
Кстати при copy листа потеряете концы длинных строк - обрежется всё что более 255 символов.
А вот что будет при ExportAsFixedFormat не знаю, предлагаю проверить.
 
 
 
#4
07.04.2015 22:51:28
Огромное спасибо, Андрей VG и Hugo, что откликнулись. Мне потребовалось немного времени во всем разобраться.
Вы создаете огромный стимул для меня познавать Excel  и Vba глубже.
Да, в части создания отдельных листов в формате xps. у меня все получилось.
Но теперь возник тупик следующего порядка
Для рассылки отдельных листов через Outlook я использовала следующий макрос.
Код
Sub mailing()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim asTo, asSubject, asBody, asAttachment
 
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
 
    asTo = Range("A17").Value
    asSubject = Range("B17").Value
    asBody = Range("C17").Value
    asAttachment = Range("D17").Value
 
    For i = 1 To UBound(asTo, 1)
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .To = asTo(i, 1)
            .Subject = asSubject(i, 1)
            .body = asBody(i, 1)
            .Attachments.Add asAttachment(i, 1)
            .Display
        End With
        On Error GoTo 0
        Set OutMail = Nothing
    Next i
cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub


Как его теперь адаптировать для рассылки отдельных листов формата .xps, полученных после применения Вами подсказанного макроса?
Или я вообще не на верном пути?
Надеюсь на Вашу помощь.
 
 
 
#5
07.04.2015 23:03:47
А у Вас этот код работает? Массив из asTo не получится никак, следовательно код на первой строке цикла споткнется.
По сути Вам в цикл Вашего первого кода(по созданию XPS) вставить код отправки. Что-то вроде этого:
Код
Sub SplitSheets2()
    Dim s As Worksheet
    Dim wb As Workbook
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim asTo, asSubject, asBody, asAttachment
  
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
  
    asTo = Range("A17").Value
    asSubject = Range("B17").Value
    asBody = Range("C17").Value
  
    Set wb = ActiveWorkbook
    For Each s In wb.Worksheets
        asAttachment = wb.Path & "" & s.Name & ".xps"
        s.ExportAsFixedFormat Type:=xlTypeXPS, Filename:=asAttachment, _
        Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .To = asTo
            .Subject = asSubject
            .body = asBody
            .Attachments.Add asAttachment
            .Display
        End With
        On Error GoTo 0
        Set OutMail = Nothing
    Next
    
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub
код писал "на коленке" - не проверял. Но с виду должен работать. Правда еще не совсем ясно - надо отправить столько же писем, сколько листов или в одном письме все файлы разом. Тогда надо будет цикл чуть иначе делать - только для вставки вложений.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#6
07.04.2015 23:12:25
Да, там явно в строках 11-14 что-то напутано, так не заработает.
А вот если при генерации xps записать пути к 10-ти файлам например в диапазон D17:D26, а левее в этих строках записать куда-что-очём, взять это всё в массивы в строках 11-14 - тогда может что и взлетит...
Точно не знаю, не пользуюсь оутлуком, не проверю.
 
 
 
#7
07.04.2015 23:22:07
Hugo- спасибо за отзывчивость, а The_Prist, я Вами просто восхищаюсь!
Все идеально!
У Вас очень крутой сайт. Становлюсь постоянным читателем,- и айда к знаниям!!!
Огромное человеческое спасибо за оперативность и качество!
 
 
 
#8
13.04.2015 20:26:03
Если это возможно...могли бы еще разок помочь в уже закрытом вопросе...
Для рассылки использую рекомендованный макрос от The Prist.
В файле из 40 листов. На каждом листе в ячейку A17 (согласно адреса в макросе) ввожу разный адрес.
Но когда макрос запускаю...Он (при создании письма на отправку) почему то везде берет один и тот же адрес активного листа.
40 раз один и тот же адрес...
В чем моя ошибка?
Буду очень признательна.
 
 
 
#9
13.04.2015 20:30:10
Цикл-то по листам есть? Может выложите?
Если кратко:
Код
For Each wsSh in Sheets
asTo = wsSh.Range("A17").Value
asSubject = wsSh.Range("B17").Value
asBody = wsSh.Range("C17").Value
Для самообразования можете почитать: Как обратиться к диапазону из VBA
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#10
13.04.2015 20:33:49
У вас переменная asTo = Range("A17").Value - диапазон из одной ячейки, откуда должны взяться разные адреса?
Неизлечимых болезней нет, есть неизлечимые люди.
 
 
 
#11
13.04.2015 22:47:34
макрос просто скопировала с сайта и вставила
Код
Sub SplitSheets2()
    Dim s As Worksheet
    Dim wb As Workbook
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim asTo, asSubject, asBody, asAttachment
   
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
   
    asTo = Range("A17").Value
    asSubject = Range("B17").Value
    asBody = Range("C17").Value
   
    Set wb = ActiveWorkbook
    For Each s In wb.Worksheets
        asAttachment = wb.Path & "" & s.Name & ".xps"
        s.ExportAsFixedFormat Type:=xlTypeXPS, Filename:=asAttachment, _
        Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .To = asTo
            .Subject = asSubject
            .body = asBody
            .Attachments.Add asAttachment
            .Display
        End With
        On Error GoTo 0
        Set OutMail = Nothing
    Next
     
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub


Вот файлик. Просто придумала для примера.
 
 
 
#12
13.04.2015 22:50:34
для TheBestoftheBest поясняю...
Я на каждом листе указываю НОВЫЙ адрес. (один). А листов 40 в исходном файле
 
 
 
#13
13.04.2015 22:50:55
Посмотрите, где происходит присвоение значение переменной asTo = в Вашем макросе, и где у The_Prist
 
 
 
#14
13.04.2015 22:51:38
Можно же было после моего сообщения как-то подумать, что ли...
Код
Set wb = ActiveWorkbook
    For Each s In wb.Worksheets
        asTo = s.Range("A17").Value
        asSubject = s.Range("B17").Value
        asBody = s.Range("C17").Value
        asAttachment = wb.Path & "" & s.Name & ".xps"
        s.ExportAsFixedFormat Type:=xlTypeXPS, Filename:=asAttachment, _
        Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .To = asTo
            .Subject = asSubject
            .body = asBody
            .Attachments.Add asAttachment
            .Display
        End With
        On Error GoTo 0
        Set OutMail = Nothing
    Next
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#15
13.04.2015 22:58:32
Да..вижу..Чувствую себя дурачком...Я с макросами на Вы..Пробую удалить из своего макроса этот кусочек и вставить как у Pirst. но все равно дает ошибку

Код
Sub SplitSheets2()
    Dim s As Worksheet
    Dim wb As Workbook
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim asTo, asSubject, asBody, asAttachment
   
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
   
    For Each wsSh In Sheets
asTo = wsSh.Range("A17").Value
asSubject = wsSh.Range("B17").Value
asBody = wsSh.Range("C17").Value
   
    Set wb = ActiveWorkbook
    For Each s In wb.Worksheets
        asAttachment = wb.Path & "" & s.Name & ".xps"
        s.ExportAsFixedFormat Type:=xlTypeXPS, Filename:=asAttachment, _
        Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .To = asTo
            .Subject = asSubject
            .body = asBody
            .Attachments.Add asAttachment
            .Display
        End With
        On Error GoTo 0
        Set OutMail = Nothing
    Next
     
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub


В такие моменты хочется..взять учебник и начать с Азов
 
 
 
#16
13.04.2015 22:59:02
Зачем вообще создавать столько страниц ?
у меня допустим тоже есть похожая задача, после корректировки планов бюджетов разослать службам необходимый набор данных на базе сводной таблицы, просто, как констатация факта (некий статичный документ с нужным форматированием) используя outlook.
Для удобства использовал срезы.
Набросал небольшой пример на основе сводной из приемов.
Я думаю подход будет понятен и переделать под свои нужды не составит проблем.
-----
Для того что бы пример(99,68 кб) корректно работал его необходимо сохранить на физический диск.
 
 
 
#17
13.04.2015 23:07:34
Да..отличная идея..Возьму на заметку. очень понравилась. Спасибо.
 
 
 
#18
13.04.2015 23:12:37
Ну если будут сложности с реализацией, пишите.
 
 
 
#19
13.04.2015 23:13:55
Спасибо. Я ответственно подойду к решению своей задачи и во всем основательно разберусь..
 
 
 
Страницы: 1
Наверх