Изменение пропорций рисунка, макрос

[laneon]

Столкнулся с проблемой - как управлять размером рисунка данными в ячейках.

Для примера -

Есть рисунок окна разделенного НЕ пополам, тоесть одна часть уже, а другая соответственно шире . В ячейке вписана ширина этих частей, например 200 и 500.

Вопрос -

Как организовать изменение пропорций этого рисунка в зависимости какие размеры вписаны в ячейки. Например чтобы когда вписать 700 и 300 то на рисунке вышеуказанного окна левая часть будет выглядеть шире нежели правая, НО общая ширина рисунка сохраняется без изменений.

Помогите пожалуйста с решением

С уважением

[EducatedFool]

Вот весь макрос:

Sub ИзменитьРазмеры()
    Dim sh1 As Shape: Set sh1 = ActiveSheet.Shapes("Rectangle 1")
    Dim sh2 As Shape: Set sh2 = ActiveSheet.Shapes("Rectangle 2")

    w1 = [c2]: w2 = [d2]: ws = sh1.Width + sh2.Width
    nw1 = ws * w1 / (w1 + w2): nw2 = ws * w2 / (w1 + w2)
    sh1.Width = nw1: sh2.Width = nw2: sh2.Left = sh1.Left + nw1
    
    sh1.TextFrame.Characters.Text = FormatNumber(100 * w1 / (w1 + w2), 2) & " %"
    sh2.TextFrame.Characters.Text = FormatNumber(100 * w2 / (w1 + w2), 2) & " %"
End Sub

См. вложение:
Поизменяйте значения в ячейка С2 и D2

[laneon]

Спасибо Большущее , еще вот один вопрос - так как окна имеют рамы и т.д. , как я могу сгруппировать другие объекты с левой или правой частями ? например вложить еще один прямоугольник или диагональ в левую или правую часть и чтобы они тоже реагировали на изменения данных в ячейках (речь идет только о ширине объектов) ?

[EducatedFool]

как я могу сгруппировать другие объекты с левой или правой частями ?

Всё элементарно делается штатными средствами Excel.
Рисуете несколько фигур, выделяете нужные фигуры, удерживая клавишу Shift, после чего в контекстном меню выбираете Сгруппировать

Потом, выделив каждую из двух фигур (имеются ввиду уже сгруппированные фигуры, размеры которых Вы указываете в ячейках), смотрите слева от строки формул имена этих фигур (например, Группа 5 для желтой фигуры), и подставляете имена этих фигур в макрос в строки

    Dim sh1 As Shape: Set sh1 = ActiveSheet.Shapes("Группа 5")
    Dim sh2 As Shape: Set sh2 = ActiveSheet.Shapes("Прямоуг. 2")

Пример во вложении.

PS: Если нужно на чертежах проставлять размеры окон, посмотрите макрос в этом сообщении.

PPS: У меня на сайте есть готовая программа для вставки изображений на лист Excel:
http://excelvba.ru/programmes/PastePictures

Надстройка позволяет искать в выбранной папке изображения, основываясь на содержимом ячеек таблицы Excel, и производить вставку найденных изображений в соседние ячейки (или в примечания к этим ячейкам).

Кроме того, надстройка умеет скачивать изображения по ссылкам, сохраняя загруженные изображения в заданной папке, и вставлять картинки в примечания к ячейкам.




Особенности надстройки вставки изображений:

• загрузка изображений по ссылкам (обычная гиперссылка, просто текст ссылки - URL, формула =ГИПЕРССЫЛКА(), и т.п.)
• поиск картинок в подпапках заданной папки (глубина поиска по подпапкам не ограничена)
• установка выбранного пользователем размера для вставляемых изображений
• отображение состояния поиска и вставки изображений (прогресс-бар)
• вывод результатов обработки таблицы (сколько изображений вставлено, сколько не найдено)
• добавление гиперссылок к вставляемым изображениям (по щелчку на картинке открывается исходный файл)
• 2 режима поиска файлов - по точному совпадению имени файла, и по началу имени файла-изображения
• 2 режима вставки картинок - подгонка размеров под ячейку, или соблюдение пропорций исходного изображения
• вывод количества файлов в выбранной папке
• возможность выбора столбца с названиями файлов, и указания номера столбца для вставляемых изображений
• возможность вставки изображений в комментарии к ячейкам

Запуск вставки изображений выполняется из меню программы (на панели инструментов)

Надстройка вставки картинок в Excel теперь поддерживает обновления - поэтому отныне надстройка будет регулярно получать новые полезные функции.

Новый функционал будет добавляться в надстройку по мере поступления ваших пожеланий.

[laneon]

преклоняюсь перед вашими знаниями, вопрос исчерпан, спасибо

насчет размеров - гениально !