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

Вход

Регистрация

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

 

= Мир MS Excel/Как соединить 2 и более одинаковых макросов в 1. - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Как соединить 2 и более одинаковых макросов в 1. (Формулы/Formulas)
Как соединить 2 и более одинаковых макросов в 1.
kotlovan Дата: Вторник, 18.06.2019, 16:08 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 30
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Добрый день!
Подобная тема была, но здесь суть немного другая. Необходимо сделать N-ое количество блоков кода с изменением ссылки на ячейку и фигуру. На примере расписан код из двух блоков. Работает всегда тот, что оказывается сверху. В чем ошибка не пойму.

[vba]
Код
Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, Range("H3")) Is Nothing Then Exit Sub
If IsNumeric(Target.Value) Then
If Target.Value > 0 Then
Worksheets("Основная").Shapes("СтрОтправлено").Fill.ForeColor.RGB = RGB(0, 176, 80)
Worksheets("Основная").Shapes("ТекстОтправлено").TextFrame.Characters.Font.Color = RGB(0, 176, 80)
ElseIf Target.Value = 0 Then
Worksheets("Основная").Shapes("СтрОтправлено").Fill.ForeColor.RGB = RGB(0, 176, 240)
Worksheets("Основная").Shapes("ТекстОтправлено").TextFrame.Characters.Font.Color = RGB(0, 176, 240)
ElseIf Target.Value < 0 Then
Worksheets("Основная").Shapes("СтрОтправлено").Fill.ForeColor.RGB = RGB(192, 0, 0)
Worksheets("Основная").Shapes("ТекстОтправлено").TextFrame.Characters.Font.Color = RGB(192, 0, 0)
End If
End If

If Intersect(Target, Range("E3")) Is Nothing Then Exit Sub
If IsNumeric(Target.Value) Then
If Target.Value > 0 Then
Worksheets("Основная").Shapes("СтрПрибыло").Fill.ForeColor.RGB = RGB(0, 176, 80)
Worksheets("Основная").Shapes("ТекстПрибыло").TextFrame.Characters.Font.Color = RGB(0, 176, 80)
ElseIf Target.Value = 0 Then
Worksheets("Основная").Shapes("СтрПрибыло").Fill.ForeColor.RGB = RGB(0, 176, 240)
Worksheets("Основная").Shapes("ТекстПрибыло").TextFrame.Characters.Font.Color = RGB(0, 176, 240)
ElseIf Target.Value < 0 Then
Worksheets("Основная").Shapes("СтрПрибыло").Fill.ForeColor.RGB = RGB(192, 0, 0)
Worksheets("Основная").Shapes("ТекстПрибыло").TextFrame.Characters.Font.Color = RGB(192, 0, 0)
End If
End If

End Sub

[/vba]
К сообщению приложен файл: 12321.xlsm (28.5 Kb)


Сообщение отредактировал kotlovan - Вторник, 18.06.2019, 16:38
 
Ответить
СообщениеДобрый день!
Подобная тема была, но здесь суть немного другая. Необходимо сделать N-ое количество блоков кода с изменением ссылки на ячейку и фигуру. На примере расписан код из двух блоков. Работает всегда тот, что оказывается сверху. В чем ошибка не пойму.

[vba]
Код
Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, Range("H3")) Is Nothing Then Exit Sub
If IsNumeric(Target.Value) Then
If Target.Value > 0 Then
Worksheets("Основная").Shapes("СтрОтправлено").Fill.ForeColor.RGB = RGB(0, 176, 80)
Worksheets("Основная").Shapes("ТекстОтправлено").TextFrame.Characters.Font.Color = RGB(0, 176, 80)
ElseIf Target.Value = 0 Then
Worksheets("Основная").Shapes("СтрОтправлено").Fill.ForeColor.RGB = RGB(0, 176, 240)
Worksheets("Основная").Shapes("ТекстОтправлено").TextFrame.Characters.Font.Color = RGB(0, 176, 240)
ElseIf Target.Value < 0 Then
Worksheets("Основная").Shapes("СтрОтправлено").Fill.ForeColor.RGB = RGB(192, 0, 0)
Worksheets("Основная").Shapes("ТекстОтправлено").TextFrame.Characters.Font.Color = RGB(192, 0, 0)
End If
End If

If Intersect(Target, Range("E3")) Is Nothing Then Exit Sub
If IsNumeric(Target.Value) Then
If Target.Value > 0 Then
Worksheets("Основная").Shapes("СтрПрибыло").Fill.ForeColor.RGB = RGB(0, 176, 80)
Worksheets("Основная").Shapes("ТекстПрибыло").TextFrame.Characters.Font.Color = RGB(0, 176, 80)
ElseIf Target.Value = 0 Then
Worksheets("Основная").Shapes("СтрПрибыло").Fill.ForeColor.RGB = RGB(0, 176, 240)
Worksheets("Основная").Shapes("ТекстПрибыло").TextFrame.Characters.Font.Color = RGB(0, 176, 240)
ElseIf Target.Value < 0 Then
Worksheets("Основная").Shapes("СтрПрибыло").Fill.ForeColor.RGB = RGB(192, 0, 0)
Worksheets("Основная").Shapes("ТекстПрибыло").TextFrame.Characters.Font.Color = RGB(192, 0, 0)
End If
End If

End Sub

[/vba]
Автор - kotlovan
Дата добавления - 18.06.2019 в 16:08
_Boroda_ Дата: Вторник, 18.06.2019, 16:12 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 16718
Репутация: 6505 ±
Замечаний: ±

2003; 2007; 2010; 2013 RUS
- Прочитайте Правила форума
- Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку #, пояснялка здесь)
- Приложите файл с исходными данными и желаемым результатом (можно вручную) в формате Excel размером до 100кб согласно п.3 Правил форума

Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
Сообщение- Прочитайте Правила форума
- Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку #, пояснялка здесь)
- Приложите файл с исходными данными и желаемым результатом (можно вручную) в формате Excel размером до 100кб согласно п.3 Правил форума
Автор - _Boroda_
Дата добавления - 18.06.2019 в 16:12
kotlovan Дата: Вторник, 18.06.2019, 16:40 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 30
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
_Boroda_, готово.
 
Ответить
Сообщение_Boroda_, готово.
Автор - kotlovan
Дата добавления - 18.06.2019 в 16:40
sboy Дата: Вторник, 18.06.2019, 17:03 | Сообщение № 4
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2566
Репутация: 724 ±
Замечаний: 0% ±

Excel 2010
Цитата kotlovan, 18.06.2019 в 16:08, в сообщении № 1 ()
В чем ошибка не пойму

в том, что Вы выходите из процедуры
[vba]
Код
If Intersect(Target, Range("H3")) Is Nothing Then Exit Sub
[/vba]

Яндекс: 410016850021169
 
Ответить
Сообщение
Цитата kotlovan, 18.06.2019 в 16:08, в сообщении № 1 ()
В чем ошибка не пойму

в том, что Вы выходите из процедуры
[vba]
Код
If Intersect(Target, Range("H3")) Is Nothing Then Exit Sub
[/vba]
Автор - sboy
Дата добавления - 18.06.2019 в 17:03
kotlovan Дата: Вторник, 18.06.2019, 17:11 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 30
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Цитата sboy, 18.06.2019 в 17:03, в сообщении № 4 ()
в том, что Вы выходите из процедуры
If Intersect(Target, Range("H3")) Is Nothing Then Exit Sub


Попробовал убрать. Ничего не изменилось.
 
Ответить
Сообщение
Цитата sboy, 18.06.2019 в 17:03, в сообщении № 4 ()
в том, что Вы выходите из процедуры
If Intersect(Target, Range("H3")) Is Nothing Then Exit Sub


Попробовал убрать. Ничего не изменилось.
Автор - kotlovan
Дата добавления - 18.06.2019 в 17:11
sboy Дата: Вторник, 18.06.2019, 17:25 | Сообщение № 6
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2566
Репутация: 724 ±
Замечаний: 0% ±

Excel 2010
Цитата kotlovan, 18.06.2019 в 17:11, в сообщении № 5 ()
Попробовал убрать

Нужно не только убрать, но и добавить)))
Например через Select адрес проверить
[vba]
Код
Sub Worksheet_Change(ByVal Target As Range)

    Select Case Target.Address(0, 0)
        Case "H3"
        'If Intersect(Target, Range("H3")) Is Nothing Then Exit Sub
            If IsNumeric(Target.Value) Then
                If Target.Value > 0 Then
                    Worksheets("Основная").Shapes("СтрОтправлено").Fill.ForeColor.RGB = RGB(0, 176, 80)
                    Worksheets("Основная").Shapes("ТекстОтправлено").TextFrame.Characters.Font.Color = RGB(0, 176, 80)
                ElseIf Target.Value = 0 Then
                    Worksheets("Основная").Shapes("СтрОтправлено").Fill.ForeColor.RGB = RGB(0, 176, 240)
                    Worksheets("Основная").Shapes("ТекстОтправлено").TextFrame.Characters.Font.Color = RGB(0, 176, 240)
                ElseIf Target.Value < 0 Then
                    Worksheets("Основная").Shapes("СтрОтправлено").Fill.ForeColor.RGB = RGB(192, 0, 0)
                    Worksheets("Основная").Shapes("ТекстОтправлено").TextFrame.Characters.Font.Color = RGB(192, 0, 0)
                End If
            End If
        Case "E3"
            'If Intersect(Target, Range("E3")) Is Nothing Then Exit Sub
            If IsNumeric(Target.Value) Then
                If Target.Value > 0 Then
                    Worksheets("Основная").Shapes("СтрПрибыло").Fill.ForeColor.RGB = RGB(0, 176, 80)
                    Worksheets("Основная").Shapes("ТекстПрибыло").TextFrame.Characters.Font.Color = RGB(0, 176, 80)
                ElseIf Target.Value = 0 Then
                    Worksheets("Основная").Shapes("СтрПрибыло").Fill.ForeColor.RGB = RGB(0, 176, 240)
                    Worksheets("Основная").Shapes("ТекстПрибыло").TextFrame.Characters.Font.Color = RGB(0, 176, 240)
                ElseIf Target.Value < 0 Then
                    Worksheets("Основная").Shapes("СтрПрибыло").Fill.ForeColor.RGB = RGB(192, 0, 0)
                    Worksheets("Основная").Shapes("ТекстПрибыло").TextFrame.Characters.Font.Color = RGB(192, 0, 0)
                End If
            End If
        End Select
End Sub
[/vba]
К сообщению приложен файл: 2718015.xlsm (29.4 Kb)

Яндекс: 410016850021169
 
Ответить
Сообщение
Цитата kotlovan, 18.06.2019 в 17:11, в сообщении № 5 ()
Попробовал убрать

Нужно не только убрать, но и добавить)))
Например через Select адрес проверить
[vba]
Код
Sub Worksheet_Change(ByVal Target As Range)

    Select Case Target.Address(0, 0)
        Case "H3"
        'If Intersect(Target, Range("H3")) Is Nothing Then Exit Sub
            If IsNumeric(Target.Value) Then
                If Target.Value > 0 Then
                    Worksheets("Основная").Shapes("СтрОтправлено").Fill.ForeColor.RGB = RGB(0, 176, 80)
                    Worksheets("Основная").Shapes("ТекстОтправлено").TextFrame.Characters.Font.Color = RGB(0, 176, 80)
                ElseIf Target.Value = 0 Then
                    Worksheets("Основная").Shapes("СтрОтправлено").Fill.ForeColor.RGB = RGB(0, 176, 240)
                    Worksheets("Основная").Shapes("ТекстОтправлено").TextFrame.Characters.Font.Color = RGB(0, 176, 240)
                ElseIf Target.Value < 0 Then
                    Worksheets("Основная").Shapes("СтрОтправлено").Fill.ForeColor.RGB = RGB(192, 0, 0)
                    Worksheets("Основная").Shapes("ТекстОтправлено").TextFrame.Characters.Font.Color = RGB(192, 0, 0)
                End If
            End If
        Case "E3"
            'If Intersect(Target, Range("E3")) Is Nothing Then Exit Sub
            If IsNumeric(Target.Value) Then
                If Target.Value > 0 Then
                    Worksheets("Основная").Shapes("СтрПрибыло").Fill.ForeColor.RGB = RGB(0, 176, 80)
                    Worksheets("Основная").Shapes("ТекстПрибыло").TextFrame.Characters.Font.Color = RGB(0, 176, 80)
                ElseIf Target.Value = 0 Then
                    Worksheets("Основная").Shapes("СтрПрибыло").Fill.ForeColor.RGB = RGB(0, 176, 240)
                    Worksheets("Основная").Shapes("ТекстПрибыло").TextFrame.Characters.Font.Color = RGB(0, 176, 240)
                ElseIf Target.Value < 0 Then
                    Worksheets("Основная").Shapes("СтрПрибыло").Fill.ForeColor.RGB = RGB(192, 0, 0)
                    Worksheets("Основная").Shapes("ТекстПрибыло").TextFrame.Characters.Font.Color = RGB(192, 0, 0)
                End If
            End If
        End Select
End Sub
[/vba]
Автор - sboy
Дата добавления - 18.06.2019 в 17:25
kotlovan Дата: Вторник, 18.06.2019, 17:29 | Сообщение № 7
Группа: Пользователи
Ранг: Новичок
Сообщений: 30
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Цитата sboy, 18.06.2019 в 17:25, в сообщении № 6 ()
Нужно не только убрать, но и добавить)))
Например через Select адрес проверить


Огромное спасибо!
 
Ответить
Сообщение
Цитата sboy, 18.06.2019 в 17:25, в сообщении № 6 ()
Нужно не только убрать, но и добавить)))
Например через Select адрес проверить


Огромное спасибо!
Автор - kotlovan
Дата добавления - 18.06.2019 в 17:29
sboy Дата: Вторник, 18.06.2019, 17:38 | Сообщение № 8
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2566
Репутация: 724 ±
Замечаний: 0% ±

Excel 2010
Пожалуйста!
Я немного оптимизировал код.
[vba]
Код
Sub Worksheet_Change(ByVal Target As Range)
    Select Case Target.Address(0, 0)
        Case "H3"
            Set shp_1 = ActiveSheet.Shapes("СтрОтправлено")
            Set shp_2 = ActiveSheet.Shapes("ТекстОтправлено")
        Case "E3"
            Set shp_1 = ActiveSheet.Shapes("СтрПрибыло")
            Set shp_2 = ActiveSheet.Shapes("ТекстПрибыло")
        Case Else
            Exit Sub
    End Select
        
    If IsNumeric(Target.Value) Then
        Select Case Target.Value
            Case Is > 0
                color_ = RGB(0, 176, 80)
            Case Is = 0
                color_ = RGB(0, 176, 240)
            Case Is < 0
                color_ = RGB(192, 0, 0)
        End Select
        
        shp_1.Fill.ForeColor.RGB = color_
        shp_2.TextFrame.Characters.Font.Color = color_
    End If
End Sub
[/vba]
К сообщению приложен файл: 0230277.xlsm (29.2 Kb)

Яндекс: 410016850021169
 
Ответить
СообщениеПожалуйста!
Я немного оптимизировал код.
[vba]
Код
Sub Worksheet_Change(ByVal Target As Range)
    Select Case Target.Address(0, 0)
        Case "H3"
            Set shp_1 = ActiveSheet.Shapes("СтрОтправлено")
            Set shp_2 = ActiveSheet.Shapes("ТекстОтправлено")
        Case "E3"
            Set shp_1 = ActiveSheet.Shapes("СтрПрибыло")
            Set shp_2 = ActiveSheet.Shapes("ТекстПрибыло")
        Case Else
            Exit Sub
    End Select
        
    If IsNumeric(Target.Value) Then
        Select Case Target.Value
            Case Is > 0
                color_ = RGB(0, 176, 80)
            Case Is = 0
                color_ = RGB(0, 176, 240)
            Case Is < 0
                color_ = RGB(192, 0, 0)
        End Select
        
        shp_1.Fill.ForeColor.RGB = color_
        shp_2.TextFrame.Characters.Font.Color = color_
    End If
End Sub
[/vba]
Автор - sboy
Дата добавления - 18.06.2019 в 17:38
kotlovan Дата: Четверг, 20.06.2019, 10:59 | Сообщение № 9
Группа: Пользователи
Ранг: Новичок
Сообщений: 30
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
[vba]
Код
Sub Worksheet_Change(ByVal Target As Range)
    Select Case Target.Address(0, 0)
        Case "H3"
            Set shp_1 = ActiveSheet.Shapes("СтрОтправлено")
            Set shp_2 = ActiveSheet.Shapes("ТекстОтправлено")
[/vba]

А есть ли возможность проверять ячейку другого листа? Это надо адрес в Case поменять?


Сообщение отредактировал kotlovan - Четверг, 20.06.2019, 11:06
 
Ответить
Сообщение[vba]
Код
Sub Worksheet_Change(ByVal Target As Range)
    Select Case Target.Address(0, 0)
        Case "H3"
            Set shp_1 = ActiveSheet.Shapes("СтрОтправлено")
            Set shp_2 = ActiveSheet.Shapes("ТекстОтправлено")
[/vba]

А есть ли возможность проверять ячейку другого листа? Это надо адрес в Case поменять?
Автор - kotlovan
Дата добавления - 20.06.2019 в 10:59
sboy Дата: Пятница, 21.06.2019, 08:59 | Сообщение № 10
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2566
Репутация: 724 ±
Замечаний: 0% ±

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

Яндекс: 410016850021169
 
Ответить
СообщениеЭто уже совсем другой вопрос, не относящийся к данной теме.
Создайте новую и опишите, что хотите получить
Автор - sboy
Дата добавления - 21.06.2019 в 08:59
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Как соединить 2 и более одинаковых макросов в 1. (Формулы/Formulas)
  • Страница 1 из 1
  • 1
Поиск:

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