Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Сохранение диапазонов как jpg - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Сохранение диапазонов как jpg
Dalm Дата: Вторник, 06.02.2024, 04:00 | Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 76
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Здравствуйте.
Помогите сделать макрос.
Как диапазоны, записанные в столбец S5:S - сохранить как jpg с именами записанными в столбце T5:T (в каталог, записанный в ячейку T3) ?
К сообщению приложен файл: 109.xlsx (11.9 Kb)
 
Ответить
СообщениеЗдравствуйте.
Помогите сделать макрос.
Как диапазоны, записанные в столбец S5:S - сохранить как jpg с именами записанными в столбце T5:T (в каталог, записанный в ячейку T3) ?

Автор - Dalm
Дата добавления - 06.02.2024 в 04:00
Nic70y Дата: Вторник, 06.02.2024, 15:24 | Сообщение № 2
Группа: Друзья
Ранг: Экселист
Сообщений: 8821
Репутация: 2298 ±
Замечаний: 0% ±

Excel 2010
[vba]
Код
Sub u_72()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    q = Range("t3").Value
    r = "s5:s15"
    For Each c In Range(r)
        s = c.Value
        If s <> "" Then
            Range(s).Copy
            Set u = ThisWorkbook.Sheets.Add
            With ActiveSheet.Pictures.Paste
                a = .Width
                b = .Height
                .Copy
            End With
            With u.ChartObjects.Add(0, 0, a, b).Chart
                .Paste
                .Export Filename:=q & c.Offset(, 1) & ".jpg", FilterName:="jpg"
            End With
            u.Delete
        End If
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
[/vba]
К сообщению приложен файл: 109.xlsm (20.0 Kb)


ЮMoney 41001841029809
 
Ответить
Сообщение[vba]
Код
Sub u_72()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    q = Range("t3").Value
    r = "s5:s15"
    For Each c In Range(r)
        s = c.Value
        If s <> "" Then
            Range(s).Copy
            Set u = ThisWorkbook.Sheets.Add
            With ActiveSheet.Pictures.Paste
                a = .Width
                b = .Height
                .Copy
            End With
            With u.ChartObjects.Add(0, 0, a, b).Chart
                .Paste
                .Export Filename:=q & c.Offset(, 1) & ".jpg", FilterName:="jpg"
            End With
            u.Delete
        End If
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
[/vba]

Автор - Nic70y
Дата добавления - 06.02.2024 в 15:24
Dalm Дата: Вторник, 06.02.2024, 16:54 | Сообщение № 3
Группа: Пользователи
Ранг: Участник
Сообщений: 76
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Nic70y, спасибо.
Но не работает.
Сохраняет просто пустые белые растры.
Эти растры примерно того же размера, что и заданные диапазоны. Но в них - ничего нет.
Я имел ввиду - сохранение растров по диапазонам - с их содержимым.
К сообщению приложен файл: 1111058.png (2.8 Kb)


Сообщение отредактировал Dalm - Вторник, 06.02.2024, 16:55
 
Ответить
СообщениеNic70y, спасибо.
Но не работает.
Сохраняет просто пустые белые растры.
Эти растры примерно того же размера, что и заданные диапазоны. Но в них - ничего нет.
Я имел ввиду - сохранение растров по диапазонам - с их содержимым.

Автор - Dalm
Дата добавления - 06.02.2024 в 16:54
Nic70y Дата: Вторник, 06.02.2024, 16:56 | Сообщение № 4
Группа: Друзья
Ранг: Экселист
Сообщений: 8821
Репутация: 2298 ±
Замечаний: 0% ±

Excel 2010
Dalm, вот сформированные файлы
К сообщению приложен файл: 3345308.jpg (3.7 Kb) · 7709861.jpg (4.7 Kb)


ЮMoney 41001841029809
 
Ответить
СообщениеDalm, вот сформированные файлы

Автор - Nic70y
Дата добавления - 06.02.2024 в 16:56
Dalm Дата: Вторник, 06.02.2024, 21:25 | Сообщение № 5
Группа: Пользователи
Ранг: Участник
Сообщений: 76
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Nic70y, понятно.
У меня - не работает.
Создает вот такие пустые файлы:
К сообщению приложен файл: 2089545.jpg (3.3 Kb)


Сообщение отредактировал Dalm - Вторник, 06.02.2024, 21:26
 
Ответить
СообщениеNic70y, понятно.
У меня - не работает.
Создает вот такие пустые файлы:

Автор - Dalm
Дата добавления - 06.02.2024 в 21:25
Nic70y Дата: Среда, 07.02.2024, 07:51 | Сообщение № 6
Группа: Друзья
Ранг: Экселист
Сообщений: 8821
Репутация: 2298 ±
Замечаний: 0% ±

Excel 2010
Dalm, это происходит в файле 109.xlsm?
или Вы перенесли макрос в другой файл?
если перенесли, приложите новый файл.


ЮMoney 41001841029809
 
Ответить
СообщениеDalm, это происходит в файле 109.xlsm?
или Вы перенесли макрос в другой файл?
если перенесли, приложите новый файл.

Автор - Nic70y
Дата добавления - 07.02.2024 в 07:51
Dalm Дата: Среда, 07.02.2024, 10:47 | Сообщение № 7
Группа: Пользователи
Ранг: Участник
Сообщений: 76
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Nic70y, нет я никуда не переносил.
Это я открываю ваш файл xlsm.
Я ничего в нем не менял.


Сообщение отредактировал Dalm - Среда, 07.02.2024, 10:47
 
Ответить
СообщениеNic70y, нет я никуда не переносил.
Это я открываю ваш файл xlsm.
Я ничего в нем не менял.

Автор - Dalm
Дата добавления - 07.02.2024 в 10:47
Dalm Дата: Среда, 07.02.2024, 21:38 | Сообщение № 8
Группа: Пользователи
Ранг: Участник
Сообщений: 76
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Как же поправить этот макрос ?
 
Ответить
СообщениеКак же поправить этот макрос ?

Автор - Dalm
Дата добавления - 07.02.2024 в 21:38
mgt Дата: Четверг, 08.02.2024, 07:41 | Сообщение № 9
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 101
Репутация: 25 ±
Замечаний: 0% ±

Excel 2010
Макрос рабочий, только что проверил.
 
Ответить
СообщениеМакрос рабочий, только что проверил.

Автор - mgt
Дата добавления - 08.02.2024 в 07:41
Pelena Дата: Четверг, 08.02.2024, 08:36 | Сообщение № 10
Группа: Админы
Ранг: Местный житель
Сообщений: 19234
Репутация: 4431 ±
Замечаний: ±

Excel 365 & Mac Excel
А у меня тоже пустые картинки получаются. Причем, если сделать паузу между ChartObjects.Add и Paste, то всё норм, а если не делать то картинка отдельно, диаграмма - отдельно

Видимо, от офиса зависит.
Задержка по времени не решает проблему, так что решения пока не нашла

Добавлено
===========

В общем, вот так у меня корректно сохраняется
[vba]
Код
Sub u_72()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    q = Range("t3").Value
    r = "s5:s15"
    For Each c In Range(r)
        s = c.Value
        If s <> "" Then
            Range(s).Copy
            Set u = ThisWorkbook.Sheets.Add
            With ActiveSheet.Pictures.Paste
                a = .Width
                b = .Height
                .Copy
            End With
            With u.ChartObjects.Add(0, 0, a, b)
                .Activate
                .Chart.Paste
                .Chart.Export Filename:=q & c.Offset(, 1) & ".jpg", FilterName:="jpg"
            End With
            u.Delete
        End If
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
[/vba]
К сообщению приложен файл: 4703702.jpg (13.6 Kb)


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеА у меня тоже пустые картинки получаются. Причем, если сделать паузу между ChartObjects.Add и Paste, то всё норм, а если не делать то картинка отдельно, диаграмма - отдельно

Видимо, от офиса зависит.
Задержка по времени не решает проблему, так что решения пока не нашла

Добавлено
===========

В общем, вот так у меня корректно сохраняется
[vba]
Код
Sub u_72()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    q = Range("t3").Value
    r = "s5:s15"
    For Each c In Range(r)
        s = c.Value
        If s <> "" Then
            Range(s).Copy
            Set u = ThisWorkbook.Sheets.Add
            With ActiveSheet.Pictures.Paste
                a = .Width
                b = .Height
                .Copy
            End With
            With u.ChartObjects.Add(0, 0, a, b)
                .Activate
                .Chart.Paste
                .Chart.Export Filename:=q & c.Offset(, 1) & ".jpg", FilterName:="jpg"
            End With
            u.Delete
        End If
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
[/vba]

Автор - Pelena
Дата добавления - 08.02.2024 в 08:36
Dalm Дата: Четверг, 08.02.2024, 09:24 | Сообщение № 11
Группа: Пользователи
Ранг: Участник
Сообщений: 76
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Pelena, спасибо.
Теперь все заработало.
 
Ответить
СообщениеPelena, спасибо.
Теперь все заработало.

Автор - Dalm
Дата добавления - 08.02.2024 в 09:24
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!