Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Как сохранять отдельный лист сразу в двух форматах, пдф+ xls
 
#1
25.12.2015 17:13:41
Прошу помочь, сам валенок в макросах.Я не программист.  Я хочу, чтобы следующий макрос сохранял лист екселя сразу в двух форматах, в одну паку. Меня полностью радует схема работы данного макроса(не мой, нашел) . Но мне надо, так-же чтобы делался дубликат дополнительно, но  в формате ексель. Что-бы сохранялся лист сразу и в пдф, и в ексель, в одну папку с одинаковым названием файла.
Головастых очень прошу помочь! Вот тот макрос, который стоит у меня.


Код
?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub Save()
    Dim F_Filename As String, Folder As String
 
    With Application
        .DisplayAlerts = False
 
        With ActiveSheet
            Set FSO = CreateObject("Scripting.FileSystemObject")
            F_Filename = Split(.[D2], ".")(0)
            Folder = .[D1] & F_Filename
            If Not FSO.FolderExists(Folder) Then FSO.CreateFolder Folder
            Set FSO = Nothing
            .PageSetup.PrintArea = Application.InputBox("Выделите область печати", Default:="$A$1:$C$26", Type:=2)
            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                    Filename:= _
                Folder & "\" & .[D2], _
                    Quality:=xlQualityHigh, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
                    OpenAfterPublish:=False
        End With
 
        .DisplayAlerts = True
    End With
 End Sub
Изменено: ivan2015 - 26.12.2015 14:35:20
 
 
 
#2
25.12.2015 17:47:18
А сами не могли найти макрос для сохранения листа в файл?
http://excelvba.ru/code/saveactivesheet

так попробуйте:
Код
?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Sub SaveFile()
    Dim F_Filename$, Folder$
    F_Filename$ = Split([d2], ".")(0)
    Folder$ = [d1] & F_Filename
 
    On Error Resume Next: MkDir Folder$
 
    ' вывод в ПДФ
    ActiveSheet.PageSetup.PrintArea = Application.InputBox("Выделите область печати", Default:="$A$1:$C$26", Type:=2)
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:=Folder & "\" & F_Filename & ".pdf"
 
    ' сохранение в XLS
    Application.ScreenUpdating = False
    Err.Clear: ActiveSheet.Copy: DoEvents ' копируем активный лист (при этом создаётся новая книга)
    If Err Then Exit Sub        ' произошла какая-то ошибка при попытке копирования листа
 
    ' убеждаемся, что активной книгой является копия листа
    If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
        ' сохраняем файл под заданным именем в формате Excel 2003
        ActiveWorkbook.SaveAs Folder & "\" & F_Filename & ".xls", xlWorkbookNormal
        ActiveWorkbook.Close False ' закрываем сохранённый файл
    End If
    Application.ScreenUpdating = True
End Sub
Надстройки для Excel  Парсинг сайтов  Мониторинг цен конкурентов
 
 
 
#3
25.12.2015 18:04:45
Игорь, ваш макрос создает ошибку, и прекращает работу ексель, идет
закрытие ексель и потом восстановление. При этом макрос создает два
файла. Есть рабочий вариант? Без закрытия ексель и его перезапуска?
Изменено: ivan2015 - 25.12.2015 18:41:06
 
 
 
#4
25.12.2015 18:21:04
ivan2015, Вы понимаете смысл слова "цитата"? Вот зачем процитировали полностью? Кнопка цитирования не для ответа. Исправьте своё сообщение.
 
 
 
#5
25.12.2015 18:56:20
ivan2015, ещё пара момементов: 1. Вы просили в двух форматах - т.е. должно быть именно два файла, а теперь говорите, что это плохо ))
Цитата
ivan2015 написал:
При этом макрос создает два файла.
2. Код следует оформлять при помощи специального тега. Ищите такую кнопку и исправьте своё сообщение. Да и писать через строку тоже не имеет смысла. Спасибо!
 
 
 
#6
25.12.2015 18:56:26
Юрий М , я прекрасно понимаю значение слова "Цитата"
Цита́та — дословная выдержка из какого-либо текста.
Я процитировал первоначальный ответ Игоря с кодом, и задал ему вопрос, но уже не в цитировании. Да, возможно цитирование получилось большое, а не короткое, и что??
Убирайте тогда функцию -цитирования, если Вас это напрягает.
Вы-же сами создали такую функцию, значит я могу ей пользоваться.
Больше того я просмотрел внимательно ваш форум и многие пользуются цитированием, и потом отвечают, или спрашивают после цитирования, что мной было проделано.

По вашей личной просьбе убрал цитату.
 
 
 
#7
25.12.2015 19:01:53
Цитата
ivan2015 написал: По вашей личной просьбе убрал цитату.
Спасибо. Возможность цитирования сделали (оставили) для того, чтобы люди могли на чём-то сделать акцент. А Вы использовали эту кнопку для ответа.
Цитата
ivan2015 написал: Убирайте тогда функцию -цитирования, если Вас это напрягает.
Да, меня напрягает, что Вы не по назначению используете эту кнопку. Про избыточное цитирование прочитайте в Правилах.  
 
 
 
#8
25.12.2015 19:05:21
Игорь  Вам спасибо  за код макроса.  Ошибку в вашем коде я  нашел , и исправил. Логика помогла.

Надо было Вам убрать в вашем макросе: If Err Then Exit Sub        ' произошла какая-то ошибка при попытке копирования листа

Теперь все четко работает!
 
 
 
#9
25.12.2015 19:18:56
Цитата
Юрий М написал:
ivan2015, свой первый пост исправлять собираетесь?
Стало легче ?-)))))))
 
 
 
#10
25.12.2015 19:22:08
Стало читабельнее. Но было бы ещё читабельнее, если бы прислушались к моему совету относительно пустых строк.
 
 
 
#11
25.12.2015 19:22:12
Да, Юрий М , нашел,  как оформлять красоту на форуме.Спасибо большое!
 
 
 
#12
25.12.2015 19:29:52
Цитата
Юрий М написал:
1. Вы просили в двух форматах - т.е. должно быть именно два файла, а теперь говорите, что это плохо ))
Не, это утверждение с положительным результатом, что сохраняется в двух файлах, как надо.,
Но ошибка там была в макросе err, которая вызывала закрытие екселя и его перезапуск- это bad было! Все починил!
 
 
 
#13
25.12.2015 23:23:33
В моём макросе нет и не было ошибок
Я ж не говорю, что у кого-то руки кривые, - так и вы не говорите, что мои макросы неправильно работают, ок? )

Либо у вас Excel глючный, либо вы код вставили в какое-то такое место, где он некорректно работает (конфликтует с имеющимся у вас кодом),
либо у вас на листе что-то не так, что копирование листа приводит к вылету Excel
Надстройки для Excel  Парсинг сайтов  Мониторинг цен конкурентов
 
 
 
#14
09.08.2016 23:04:11
Игорь, столкнулся с такой же ошибкой, вылетает ёксель. Причем не во всех файлах, а лишь в одном. Макрос подключен как .xla.. дело не в офисе, а скорее всего в наших кривых ручках. код прилагаю, помогите, что не так. Пошагово выполняет, в отладчике. при запуске вылетает. Хелп!
Код
?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
Sub SaveFile()
    Dim F_Filename$, Folder$, Folder2$
    Dim strDate As String
    Dim strPath As String
    Dim DogNumb As String
    Dim wsTmpSh As Worksheet
    Dim Rgg As Range
    Set Rgg = ActiveSheet.Range("A1:F43")
    strPath = "C:\Users\Alexander\Desktop\Константин\МЕРОПРИЯТИЯ"
    Dim sFileName As String, sNewFileName As String
    Dim a As String
    a = Range("F3")
     
   DogNumb = Sheets("ФУРШЕТ").Range("F4").Value
     
    F_Filename$ = [C4] 'Split([C4], ".")(0)
    Folder$ = strPath & "\" & [C5] & " " & F_Filename
    Folder2$ = strPath & "\" & "КАРТИНКИ"
    strDate = Format(ActiveSheet.Range("$C$5"), "dd/mm/yy")
    On Error Resume Next: MkDir Folder$
  
     Application.DisplayAlerts = False
    Application.ScreenUpdating = False
     
    ' вывод в PDF
    ActiveSheet.PageSetup.PrintArea = "$A$1:$F$43" ', Type:=2)
    Подготовить
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Folder & "\" & strDate & " " & F_Filename & ".pdf"
 
    ' сохранить JPG
        With Rgg
        .CopyPicture
        Set wsTmpSh = ThisWorkbook.Sheets.Add
        With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart
            .ChartArea.Border.LineStyle = 0
            .Paste
            .Export Filename:=Folder2 & "\" & strDate & " " & "ДОГОВОР (Ю)-" & DogNumb & " " & strDate & " " & ".jpeg", FilterName:="JPG"
            .Parent.Delete
        End With
    End With
    wsTmpSh.Delete
 
    ' сохранение в XLS
 
    Err.Clear: ActiveSheet.Copy: DoEvents ' копируем активный лист (при этом создаётся новая книга)
    If Err Then Exit Sub        ' произошла какая-то ошибка при попытке копирования листа
 
    ' убеждаемся, что активной книгой является копия листа
    If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
        ' сохраняем файл под заданным именем в формате Excel 2003
        ActiveWorkbook.SaveAs Folder & "\" & strDate & " " & F_Filename & ".xls", xlWorkbookNormal
        ActiveWorkbook.Close False ' закрываем сохранённый файл
    End If
  
  
    Вернуть
    Select Case a
    Case "Ф"
        sFileName = "C:\Users\Alexander\Desktop\Константин\МЕРОПРИЯТИЯ\ДОГОВОР ФИЗ ЛИЦО.doc"    'имя файла для копирования
        sNewFileName = Folder & "\" & "ДОГОВОР (Ф)-" & DogNumb & ". " & strDate & ".doc"     'имя копируемого файла. Директория(в данном случае диск D) должна существовать
    If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "Ошибка": Exit Sub
     
    FileCopy sFileName, sNewFileName 'копируем файл
    Case "Ю"
            sFileName = "C:\Users\Alexander\Desktop\Константин\МЕРОПРИЯТИЯ\ДОГОВОР ЮР ЛИЦО.doc"    'имя файла для копирования
        sNewFileName = Folder & "\" & "ДОГОВОР (Ю)-" & DogNumb & ". " & strDate & ".doc" 'имя копируемого файла. Директория(в данном случае диск D) должна существовать
    If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "Ошибка": Exit Sub
    FileCopy sFileName, sNewFileName 'копируем файл
    End Select
     Sheets("ФУРШЕТ").Range("F4").Value = _
     Sheets("ФУРШЕТ").Range("F4").Value + 1
'  ThisWorkbook.Save
    Shell "explorer.exe " & Folder, vbMaximizedFocus
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
 
Sub Подготовить()
 Dim Rng As Range
    Set Rng = Range("A1:F43")
    With Rng.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("A2:F2,A11:F11").Interior.Color = RGB(220, 220, 220)
    Range("F3:F4").Font.Color = vbWhite
End Sub
Sub Вернуть()
    Dim Rng As Range
    Set Rng = Range("A1:F43")
    With Rng.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("F3:F4").Font.Color = vbRed
End Sub
Путь в тысячу ли начинается со слов: "Все в порядке, но есть пара правок..." Лао Цзы
 
 
 
#15
10.08.2016 14:43:19
Игорь, сможете помочь?
Путь в тысячу ли начинается со слов: "Все в порядке, но есть пара правок..." Лао Цзы
 
 
 
Страницы: 1
Читают тему
Наверх
Loading...