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

Вход

Регистрация

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

 

= Мир MS Excel/Изменение шрифта относительно заполнения ячейки - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Изменение шрифта относительно заполнения ячейки (Макросы/Sub)
Изменение шрифта относительно заполнения ячейки
v_i_t_a_l_y_a Дата: Понедельник, 16.05.2016, 15:25 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 19
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Добрый день, пытаюсь создать скрипт для автоматического изменения размера шрифта в заданной ячейке.
Суть в том, что если у нас в ячейке до 11 символов - шрифт 26, если 12 - шрифт 25, если 13 - 23 и тд.
У меня работает следующая схема
[vba]
Код

    If Len(CStr(Cells(4, 2))) > 11 Then
           Cells(4, 2).Font.Size = 25
    End If
    If Len(CStr(Cells(4, 2))) > 12 Then
           Cells(4, 2).Font.Size = 23
    End If
    If Len(CStr(Cells(4, 2))) > 13 Then
           Cells(4, 2).Font.Size = 21
    End If
    If Len(CStr(Cells(4, 2))) > 14 Then
           Cells(4, 2).Font.Size = 20
    End If
    If Len(CStr(Cells(4, 2))) > 15 Then
           Cells(4, 2).Font.Size = 16
    End If
    If Len(CStr(Cells(4, 2))) > 20 Then
           Cells(4, 2).Font.Size = 12
    End If
    If Len(CStr(Cells(4, 2))) <= 11  Then
           Cells(4, 2).Font.Size = 26
    End If
[/vba]
Все отлично работает, но у меня есть две ячейки в которых размер должен быть одинаковым

например если в Cells(4, 2) - 3 символа, то шрифт стоит 26, а в Cells(5, 2)- символов больше 11, должен стать шрифт 25 в обоих ячейках, и наоборот если в первой больше символов чем во второй, шрифты должны изменятся одинаково.
Пытался сделать следующее
[vba]
Код

    If Len(CStr(Cells(4, 2))) > 11 Then
           Cells(4, 2).Font.Size = 25
    End If

    If Len(CStr(Cells(5, 2))) > 11 Then
           Cells(5, 2).Font.Size = 25
    End If
[/vba]
работает только последняя строка

так тоже не идет
[vba]
Код

    If Len(CStr(Cells(4, 2))) > 11 or Len(CStr(Cells(5, 2))) > 11 Then
          Cells(4, 2).Font.Size = 25
          Cells(5, 2).Font.Size = 25
    End If
[/vba]
Как быть?
[moder]Замечания исправлены[/moder]


Сообщение отредактировал SLAVICK - Понедельник, 16.05.2016, 16:46
 
Ответить
СообщениеДобрый день, пытаюсь создать скрипт для автоматического изменения размера шрифта в заданной ячейке.
Суть в том, что если у нас в ячейке до 11 символов - шрифт 26, если 12 - шрифт 25, если 13 - 23 и тд.
У меня работает следующая схема
[vba]
Код

    If Len(CStr(Cells(4, 2))) > 11 Then
           Cells(4, 2).Font.Size = 25
    End If
    If Len(CStr(Cells(4, 2))) > 12 Then
           Cells(4, 2).Font.Size = 23
    End If
    If Len(CStr(Cells(4, 2))) > 13 Then
           Cells(4, 2).Font.Size = 21
    End If
    If Len(CStr(Cells(4, 2))) > 14 Then
           Cells(4, 2).Font.Size = 20
    End If
    If Len(CStr(Cells(4, 2))) > 15 Then
           Cells(4, 2).Font.Size = 16
    End If
    If Len(CStr(Cells(4, 2))) > 20 Then
           Cells(4, 2).Font.Size = 12
    End If
    If Len(CStr(Cells(4, 2))) <= 11  Then
           Cells(4, 2).Font.Size = 26
    End If
[/vba]
Все отлично работает, но у меня есть две ячейки в которых размер должен быть одинаковым

например если в Cells(4, 2) - 3 символа, то шрифт стоит 26, а в Cells(5, 2)- символов больше 11, должен стать шрифт 25 в обоих ячейках, и наоборот если в первой больше символов чем во второй, шрифты должны изменятся одинаково.
Пытался сделать следующее
[vba]
Код

    If Len(CStr(Cells(4, 2))) > 11 Then
           Cells(4, 2).Font.Size = 25
    End If

    If Len(CStr(Cells(5, 2))) > 11 Then
           Cells(5, 2).Font.Size = 25
    End If
[/vba]
работает только последняя строка

так тоже не идет
[vba]
Код

    If Len(CStr(Cells(4, 2))) > 11 or Len(CStr(Cells(5, 2))) > 11 Then
          Cells(4, 2).Font.Size = 25
          Cells(5, 2).Font.Size = 25
    End If
[/vba]
Как быть?
[moder]Замечания исправлены[/moder]

Автор - v_i_t_a_l_y_a
Дата добавления - 16.05.2016 в 15:25
v_i_t_a_l_y_a Дата: Понедельник, 16.05.2016, 16:40 | Сообщение № 2
Группа: Пользователи
Ранг: Новичок
Сообщений: 19
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
В приложении пример файла
К сообщению приложен файл: 6688437.xlsm(15Kb)
 
Ответить
СообщениеВ приложении пример файла

Автор - v_i_t_a_l_y_a
Дата добавления - 16.05.2016 в 16:40
Karataev Дата: Понедельник, 16.05.2016, 16:49 | Сообщение № 3
Группа: Проверенные
Ранг: Ветеран
Сообщений: 837
Репутация: 312 ±
Замечаний: 0% ±

Excel
[vba]
Код
Sub jjj()

    Dim lngMax As Long
    
    lngMax = WorksheetFunction.Max(Len(Cells(4, 2).Value), Len(Cells(5, 2).Value))
    
    Select Case lngMax
        Case Is > 20
            Cells(4, 2).Font.Size = 12
            Cells(5, 2).Font.Size = 12
        Case Is > 15
            Cells(4, 2).Font.Size = 16
            Cells(5, 2).Font.Size = 16
        Case Is > 14
            Cells(4, 2).Font.Size = 20
            Cells(5, 2).Font.Size = 20
        Case Is > 13
            Cells(4, 2).Font.Size = 21
            Cells(5, 2).Font.Size = 21
        Case Is > 12
            Cells(4, 2).Font.Size = 23
            Cells(5, 2).Font.Size = 23
        Case Is > 11
            Cells(4, 2).Font.Size = 25
            Cells(5, 2).Font.Size = 25
        Case Is <= 11
            Cells(4, 2).Font.Size = 26
            Cells(5, 2).Font.Size = 26
    End Select

End Sub
[/vba]


 
Ответить
Сообщение[vba]
Код
Sub jjj()

    Dim lngMax As Long
    
    lngMax = WorksheetFunction.Max(Len(Cells(4, 2).Value), Len(Cells(5, 2).Value))
    
    Select Case lngMax
        Case Is > 20
            Cells(4, 2).Font.Size = 12
            Cells(5, 2).Font.Size = 12
        Case Is > 15
            Cells(4, 2).Font.Size = 16
            Cells(5, 2).Font.Size = 16
        Case Is > 14
            Cells(4, 2).Font.Size = 20
            Cells(5, 2).Font.Size = 20
        Case Is > 13
            Cells(4, 2).Font.Size = 21
            Cells(5, 2).Font.Size = 21
        Case Is > 12
            Cells(4, 2).Font.Size = 23
            Cells(5, 2).Font.Size = 23
        Case Is > 11
            Cells(4, 2).Font.Size = 25
            Cells(5, 2).Font.Size = 25
        Case Is <= 11
            Cells(4, 2).Font.Size = 26
            Cells(5, 2).Font.Size = 26
    End Select

End Sub
[/vba]

Автор - Karataev
Дата добавления - 16.05.2016 в 16:49
v_i_t_a_l_y_a Дата: Понедельник, 16.05.2016, 17:00 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 19
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Спасибо, но при изменении любой ячейки из двух, мы должны получать одинаковый результат в обоих ячейках.
В Вашем варианте изменяется по разному размер шрифта в ячейках

Это тоже-самое, что и мой третий вариант.


Сообщение отредактировал v_i_t_a_l_y_a - Понедельник, 16.05.2016, 17:02
 
Ответить
СообщениеСпасибо, но при изменении любой ячейки из двух, мы должны получать одинаковый результат в обоих ячейках.
В Вашем варианте изменяется по разному размер шрифта в ячейках

Это тоже-самое, что и мой третий вариант.

Автор - v_i_t_a_l_y_a
Дата добавления - 16.05.2016 в 17:00
RAN Дата: Понедельник, 16.05.2016, 21:39 | Сообщение № 5
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4419
Репутация: 872 ±
Замечаний: 0% ±

2010
yes
[vba]
Код
Sub Мяу()
    Dim minmax&, cl As Range, fs&
    minmax = Len(Cells(4, 2)) - Len(Cells(5, 2))
    Set cl = IIf(minmax > 0, Cells(4, 2), Cells(5, 2))
    fs = 26
    If Len(cl) > 15 Then
        fs = 16
    ElseIf Len(cl) > 14 Then
        fs = 20
    ElseIf Len(cl) > 13 Then
        fs = 21
    ElseIf Len(cl) > 12 Then
        fs = 23
    ElseIf Len(cl) > 11 Then
        fs = 25
    End If
    Cells(4, 2).Font.Size = fs
    Cells(5, 2).Font.Size = fs
End Sub
[/vba]


Быть или не быть, вот в чем загвоздка!
 
Ответить
Сообщениеyes
[vba]
Код
Sub Мяу()
    Dim minmax&, cl As Range, fs&
    minmax = Len(Cells(4, 2)) - Len(Cells(5, 2))
    Set cl = IIf(minmax > 0, Cells(4, 2), Cells(5, 2))
    fs = 26
    If Len(cl) > 15 Then
        fs = 16
    ElseIf Len(cl) > 14 Then
        fs = 20
    ElseIf Len(cl) > 13 Then
        fs = 21
    ElseIf Len(cl) > 12 Then
        fs = 23
    ElseIf Len(cl) > 11 Then
        fs = 25
    End If
    Cells(4, 2).Font.Size = fs
    Cells(5, 2).Font.Size = fs
End Sub
[/vba]

Автор - RAN
Дата добавления - 16.05.2016 в 21:39
v_i_t_a_l_y_a Дата: Вторник, 17.05.2016, 07:56 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 19
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Спасибо, большое! Сделал по Вашему коду для двух ячеек где нужны идентичные параметры, и по своему для самостоятельных ячеек.
 
Ответить
СообщениеСпасибо, большое! Сделал по Вашему коду для двух ячеек где нужны идентичные параметры, и по своему для самостоятельных ячеек.

Автор - v_i_t_a_l_y_a
Дата добавления - 17.05.2016 в 07:56
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Изменение шрифта относительно заполнения ячейки (Макросы/Sub)
Страница 1 из 11
Поиск:

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