Note: The other languages of the website are Google-translated. Back to English

Как автоматически изменить размер формы на основе / в зависимости от указанного значения ячейки в Excel?

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

Автоматическое изменение размера формы на основе указанного значения ячейки с кодом VBA


Автоматическое изменение размера формы на основе указанного значения ячейки с кодом VBA

Следующий код VBA может помочь вам изменить определенный размер фигуры на основе указанного значения ячейки в текущем листе. Пожалуйста, сделайте следующее.

1. Щелкните правой кнопкой мыши вкладку листа с фигурой, размер которой нужно изменить, а затем щелкните Просмотреть код из контекстного меню.

2. в Microsoft Visual Basic для приложений окна, скопируйте и вставьте следующий код VBA в окно кода.

Код VBA: автоматическое изменение размера формы на основе указанного значения ячейки в Excel

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Row = 2 And Target.Column = 1 Then
        Call SizeCircle("Oval 2", Val(Target.Value))
    End If
End Sub
Sub SizeCircle(Name As String, Diameter)
    Dim xCenterX As Single
    Dim xCenterY As Single
    Dim xCircle As Shape
    Dim xDiameter As Single
    On Error GoTo ExitSub
    xDiameter = Diameter
    If xDiameter > 10 Then xDiameter = 10
    If xDiameter < 1 Then xDiameter = 1
    Set xCircle = ActiveSheet.Shapes(Name)
    With xCircle
        xCenterX = .Left + (.Width / 2)
        xCenterY = .Top + (.Height / 2)
        .Width = Application.CentimetersToPoints(xDiameter)
        .Height = Application.CentimetersToPoints(xDiameter)
        .Left = xCenterX - (.Width / 2)
        .Top = xCenterY - (.Height / 2)
    End With
ExitSub:
End Sub

Внимание: В коде "Овал 2»- это имя формы, размер которой вы измените. И Ряд = 2, Столбец = 1 означает, что размер формы «Овал 2» будет изменен на значение в A2. Пожалуйста, измените их по своему усмотрению.

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

Код VBA: автоматическое изменение размера нескольких фигур на основе значения разных указанных ячеек в Excel

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xAddress As String
    On Error Resume Next
    If Target.CountLarge = 1 Then
        xAddress = Target.Address(0, 0)
        If xAddress = "A1" Then
            Call SizeCircle("Oval 1", Val(Target.Value))
        ElseIf xAddress = "A2" Then
            Call SizeCircle("Smiley Face 3", Val(Target.Value))
        ElseIf xAddress = "A3" Then
            Call SizeCircle("Heart 2", Val(Target.Value))
        End If
    End If
End Sub

Sub SizeCircle(Name As String, Diameter)
    Dim xCenterX As Single
    Dim xCenterY As Single
    Dim xCircle As Shape
    Dim xDiameter As Single
    On Error GoTo ExitSub
    xDiameter = Diameter
    If xDiameter > 10 Then xDiameter = 10
    If xDiameter < 1 Then xDiameter = 1
    Set xCircle = ActiveSheet.Shapes(Name)
    With xCircle
        xCenterX = .Left + (.Width / 2)
        xCenterY = .Top + (.Height / 2)
        .Width = Application.CentimetersToPoints(xDiameter)
        .Height = Application.CentimetersToPoints(xDiameter)
        .Left = xCenterX - (.Width / 2)
        .Top = xCenterY - (.Height / 2)
    End With
ExitSub:
End Sub

Ноты:

1) В коде «Овал 1","Смайлик 3(Основной ключ) и Сердце 3»- это названия фигур, вы автоматически измените их размеры. И A1, A2 иA3 - это ячейки, значения которых вы будете автоматически изменять размер фигур.
2) Если вы хотите добавить больше фигур, добавьте линии "ElseIf xAddress = "A3" Тогда" а также "Call SizeCircle (" Heart 2 ", Val (Target.Value))"выше первого"End If"в коде. И измените адрес ячейки и имя формы в соответствии с вашими потребностями.

3. Нажмите другой + Q клавиши одновременно, чтобы закрыть Microsoft Visual Basic для приложений окно.

С этого момента, когда вы меняете значение в ячейке A2, размер овала 2 формы будет изменен автоматически. Смотрите скриншот:

Или измените значения в ячейках A1, A2 и A3, чтобы автоматически изменить размеры соответствующих форм «Овал 1», «Смайлик 3» и «Сердце 3». Смотрите скриншот:

Внимание: Размер фигуры больше не будет изменяться, если значение ячейки больше 10.


Список и экспорт всех фигур в текущей книге Excel:

Компания Экспорт графики полезности Kutools for Excel поможет вам быстро составить список всех фигур в текущей книге, и вы можете экспортировать их все в определенную папку сразу, как показано на скриншоте ниже shwon. Скачайте и попробуйте прямо сейчас! (30-дневная бесплатная трасса)


Статьи по теме:


Лучшие инструменты для работы в офисе

Kutools for Excel решает большинство ваших проблем и увеличивает вашу производительность на 80%

  • Снова использовать: Быстро вставить сложные формулы, диаграммы и все, что вы использовали раньше; Зашифровать ячейки с паролем; Создать список рассылки и отправлять электронные письма ...
  • Бар Супер Формулы (легко редактировать несколько строк текста и формул); Макет для чтения (легко читать и редактировать большое количество ячеек); Вставить в отфильтрованный диапазон...
  • Объединить ячейки / строки / столбцы без потери данных; Разделить содержимое ячеек; Объединить повторяющиеся строки / столбцы... Предотвращение дублирования ячеек; Сравнить диапазоны...
  • Выберите Дубликат или Уникальный Ряды; Выбрать пустые строки (все ячейки пустые); Супер находка и нечеткая находка во многих рабочих тетрадях; Случайный выбор ...
  • Точная копия Несколько ячеек без изменения ссылки на формулу; Автоматическое создание ссылок на несколько листов; Вставить пули, Флажки и многое другое ...
  • Извлечь текст, Добавить текст, Удалить по позиции, Удалить пробел; Создание и печать промежуточных итогов по страницам; Преобразование содержимого ячеек в комментарии...
  • Суперфильтр (сохранять и применять схемы фильтров к другим листам); Расширенная сортировка по месяцам / неделям / дням, периодичности и др .; Специальный фильтр жирным, курсивом ...
  • Комбинируйте книги и рабочие листы; Объединить таблицы на основе ключевых столбцов; Разделить данные на несколько листов; Пакетное преобразование xls, xlsx и PDF...
  • Более 300 мощных функций. Поддерживает Office/Excel 2007-2021 и 365. Поддерживает все языки. Простое развертывание на вашем предприятии или в организации. Полнофункциональная 30-дневная бесплатная пробная версия. 60-дневная гарантия возврата денег.
вкладка kte 201905

Вкладка Office: интерфейс с вкладками в Office и упрощение работы

  • Включение редактирования и чтения с вкладками в Word, Excel, PowerPoint, Издатель, доступ, Visio и проект.
  • Открывайте и создавайте несколько документов на новых вкладках одного окна, а не в новых окнах.
  • Повышает вашу продуктивность на 50% и сокращает количество щелчков мышью на сотни каждый день!
офисный дно
Сортировать комментарии по
Комментарии (16)
Оценок пока нет. Оцените первым!
Этот комментарий был сведен к минимуму модератором на сайте
Как бы вы выполнили это с несколькими фигурами, каждая из которых зависит от разных ячеек?
Этот комментарий был сведен к минимуму модератором на сайте
Дорогая Джейд,
Статья дополнена новым разделом кода, который может помочь вам выполнить несколько фигур, каждая из которых зависит от разных ячеек. Спасибо за ваш комментарий.

С наилучшими пожеланиями,
Crystal
Этот комментарий был сведен к минимуму модератором на сайте
Как назвать свою форму? Как в приведенном выше примере присвоить имя Овал 2 нарисованному вами кругу?
Этот комментарий был сведен к минимуму модератором на сайте
Дорогой Ранджит,
Чтобы назвать фигуру, выберите эту фигуру, введите имя фигуры в поле «Имя» и нажмите клавишу «Ввод». См. приведенное ниже изображение.
Этот комментарий был сведен к минимуму модератором на сайте
Привет, как мне воспроизвести одно и то же для нескольких фигур, связанных с несколькими ячейками в одном модуле?
Этот комментарий был сведен к минимуму модератором на сайте
Дорогая Абхиная,
Статья дополнена новым разделом кода, который может помочь вам выполнить несколько фигур, каждая из которых зависит от разных ячеек. Спасибо за ваш комментарий.

С наилучшими пожеланиями,
Crystal
Этот комментарий был сведен к минимуму модератором на сайте
Здравствуйте,
Я пытался использовать ваш пост, чтобы написать свой собственный код VBA, но, похоже, не очень далеко. В основном потому, что я не совсем понимаю VBA и просто пытаюсь адаптировать ваш. Мне было интересно, не могли бы вы помочь. Я хочу изменить длину прямоугольника в зависимости от значения в ячейке. Я хотел бы, чтобы ширина прямоугольника оставалась неизменной, а длина менялась. Я хотел бы, чтобы обе левые вершины оставались на одном месте и удлинялись вправо. Это возможно?
спасибо
Этот комментарий был сведен к минимуму модератором на сайте
Уважаемый лан,
Надеюсь, что следующий код VBA может решить вашу проблему. (Пожалуйста, замените овал 1 на свое собственное название формы)

Private Sub Worksheet_Change (ByVal Target As Range)
On Error Resume Next
Если Target.Row = 2 и Target.Column = 1, тогда
Вызов SizeCircle("Овал 1", Val(Target.Value))
End If
End Sub
Sub SizeCircle (имя как строка, диаметр)
Dim xCircle как форма
Размер xДиаметр как одиночный
При ошибке GoTo ExitSub
хдиаметр = диаметр
Если xDiameter > 10, тогда xDiameter = 10
Если xDiameter < 1, тогда xDiameter = 1
Установите xCircle = ActiveSheet.Shapes(Name)
xCircle.ScaleWidth 1.5, мсоложь, мсоскалефромтоплефт
С xCircle
.Локкаспектратио = мсоложь
.Width = Application.CentimetersToPoints(xDiameter)
Конец с
ExitSub:
End Sub
Этот комментарий был сведен к минимуму модератором на сайте
Привет, есть ли способ расширить фигуру в двух измерениях (вместо того, чтобы увеличивать размер фигуры на 5, увеличьте ее на 5 по горизонтали и на 3 по вертикали)?
Этот комментарий был сведен к минимуму модератором на сайте
Дорогой Сэм,
Следующий сценарий VBA может помочь вам решить проблему. И два измерения — это ячейки A1 и B1.

Private Sub Worksheet_Change (ByVal Target As Range)
On Error Resume Next
Если Цель.Количество = 1 Тогда
Если Не Пересечь(Цель, Диапазон("A1:B1")) Ничего, Тогда
Вызов SizeCircle("Овал 2", Array(Val(Range("A1").Value), Val(Range("B1").Value)))
End If
End If
End Sub
Sub SizeCircle (имя как строка, Arr как вариант)
Дим я пока
Dim xCenterX как одиночный
Dim xCenterY как одиночный
Dim xCircle как форма
При ошибке GoTo ExitSub
Для I = 0 To UBound(Arr)
Если Arr(I) > 10 Тогда
Приб(I) = 10
ИначеЕсли Arr(I) < 1 Тогда
Приб(I) = 1
End If
Далее
Установите xCircle = ActiveSheet.Shapes(Name)
С xCircle
xCenterX = .Слева + (.Ширина/2)
xCenterY = .Верх + (.Высота/2)
.Width = Application.CentimetersToPoints(Arr(0))
.Height = Application.CentimetersToPoints(Arr(1))
.Слева = xCenterX - (.Ширина / 2)
.Верх = xЦентрY - (.Высота/2)
Конец с
ExitSub:
End Sub
Этот комментарий был сведен к минимуму модератором на сайте
Есть ли способ сделать это с изображениями? Кажется, мне не повезло с использованием кода, как опубликовано.

5 изображений в таблице лидеров, я хочу, чтобы изображения на 1-м месте или на первом месте были больше. Поэтому у меня есть 1 фиксированных размера изображения: 2x1 для не первого места или 2x2 для 4-го места (например). У меня уже настроен рейтинг, поэтому я могу использовать его для создания размеров в определенных ячейках для каждого изображения (т.е. использовать оператор IF, чтобы IF RANK был 1-м размером, ширина равнялась 1). Однако мой VBA довольно слаб.

В основном я хочу - при обновлении листа - посмотреть ячейки размера изображения и установить каждый размер изображения в соответствии с конкретным результатом ячеек размера изображения. Я не вижу в VBA выше, как именно это работает, но я думаю, что это должно быть легко!
Этот комментарий был сведен к минимуму модератором на сайте
Привет, Кристал,

Я хотел бы спросить вас, есть ли способ выбрать цвет (красная ячейка = красная форма) и имя из определенных ячеек. можно ли также автоматически создавать формы из VBA?

Огромное спасибо заранее :)

Кэрол
Этот комментарий был сведен к минимуму модератором на сайте
привет кристалл
а если для определения стороны куба, треугольника, прямоугольника надо определить исходя из длины, ширины? Помогите пожалуйста мне

Спасибо
кресло
Этот комментарий был сведен к минимуму модератором на сайте
Привет Чарил,
Извините, пока не могу вам с этим помочь. Спасибо за ваш комментарий.
Этот комментарий был сведен к минимуму модератором на сайте
есть ли способ, чтобы это работало, если ячейка, которую вы используете для установки размера, является результатом формулы, а не просто статическим значением, которое вы вводите вручную?
Этот комментарий был сведен к минимуму модератором на сайте
Привет, mahnz, приведенный ниже код VBA может помочь вам решить проблему. Вам просто нужно изменить ячейки значений и имена фигур в коде на основе ваших собственных данных.
Частная подпрограмма Worksheet_Calculate()
'Обновлено Extendoffice 20211105
On Error Resume Next
Вызов SizeCircle("Овал 1", Val(Диапазон("A1").Значение)) 'A1 — это ячейка значения, овал 1 — имя фигуры.
Вызов SizeCircle("Smiley Face 2", Val(Range("A2").Value))
Вызов SizeCircle("Heart 3", Val(Range("A3").Value))

End Sub
Private Sub Worksheet_Change (ByVal Target As Range)
Dim xAddress как строка
On Error Resume Next
Если Target.CountLarge = 1 Тогда
xAddress = Цель.Адрес(0, 0)
Если xAddress = "A1" Тогда
Вызов SizeCircle("Овал 1", Val(Target.Value))
ElseIf xAddress = "A2" Тогда
Вызов SizeCircle("Смайлик 2", Val(Target.Value))
ElseIf xAddress = "A3" Тогда
Вызов SizeCircle("Heart 3", Val(Target.Value))

End If
End If
End Sub

Sub SizeCircle (имя как строка, диаметр)
Dim xCenterX как одиночный
Dim xCenterY как одиночный
Dim xCircle как форма
Размер xДиаметр как одиночный
При ошибке GoTo ExitSub
хдиаметр = диаметр
Если xDiameter > 10, тогда xDiameter = 10
Если xDiameter < 1, тогда xDiameter = 1
Установите xCircle = ActiveSheet.Shapes(Name)
С xCircle
xCenterX = .Слева + (.Ширина/2)
xCenterY = .Верх + (.Высота/2)
.Width = Application.CentimetersToPoints(xDiameter)
.Height = Application.CentimetersToPoints(xDiameter)
.Слева = xCenterX - (.Ширина / 2)
.Верх = xЦентрY - (.Высота/2)
Конец с
ExitSub:
End Sub

Здесь еще нет комментариев
Оставляйте свои комментарии
Публикация как гость
×
Оценить этот пост:
0   Характеристики
Предлагаемые места

Подписывайтесь на Нас

Copyright © 2009 - www.extendoffice.ком. | Все права защищены. Питаться от ExtendOffice, | Карта сайта
Microsoft и логотип Office являются товарными знаками или зарегистрированными товарными знаками Microsoft Corporation в США и / или других странах.
Защищено Sectigo SSL