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

Вход

Регистрация

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

 

= Мир MS Excel/Передать переменные в другой макрос, как это реализовать ? - Мир MS Excel

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

Excel 2016
День добрый!
Написал небольшую раскраску, на основе готового макроса из РуНета:

[vba]
Код

    Dim ra As Range, cell As Range, res, txt$, v, pos&
    On Error Resume Next: Err.Clear

    ' Линия БОПП
    Range("O9:V9") = Range("B36:I36").Value ' Линия БОПП
    Range("O9:V9").Font.Color = 0
    
    Set ra = Range("O9:V9")     ' диапазон для поиска
    ' минимальный отход
    res = Application.Round(Application.WorksheetFunction.Min(Range("B30:I30")), 0)
    Цвет = -11489280 ' зеленный
    ' процедура раскраски текста
            txt$ = Trim(res)
            For Each cell In ra.Cells    ' перебираем все ячейки
                pos = 1
                If cell.Text Like "*" & txt & "*" Then
                    arr = Split(cell.Text, txt, , vbTextCompare)   ' разбивает текст ячейки на части
                    If UBound(arr) > 0 Then    ' если подстрока найдена
                        For Each v In arr    ' перебираем все вхождения
                            pos = pos + Len(v)    ' начальная позиция
                            With cell.Characters(pos, Len(txt))
                    .Font.Color = Цвет    ' выделяем цветом
                            End With
                            pos = pos + Len(txt)
                        Next v
                    End If
                End If
            Next cell

        ' максимальный отход
        res = Application.Round(Application.WorksheetFunction.Max(Range("B30:I30")), 0)
        Цвет = -16777024 ' красный
        
       ' процедура раскраски текста
            txt$ = Trim(res)
            For Each cell In ra.Cells    ' перебираем все ячейки
                pos = 1
                If cell.Text Like "*" & txt & "*" Then
                    arr = Split(cell.Text, txt, , vbTextCompare)   ' разбивает текст ячейки на части
                    If UBound(arr) > 0 Then    ' если подстрока найдена
                        For Each v In arr    ' перебираем все вхождения
                            pos = pos + Len(v)    ' начальная позиция
                            With cell.Characters(pos, Len(txt))
                    .Font.Color = Цвет    ' выделяем цветом
                            End With
                            pos = pos + Len(txt)
                        Next v
                    End If
                End If
            Next cell
[/vba]

Как мне выделить в отдельное место кода эту процедуру раскраски, чтоб не плодить много букв кода ?
То есть определил в диапазоне макс значение, вызвал процедуру, раскрасил, далее ищем минимальное значение и снова раскраска текста ?

Вот примерный скелет кода, но переменные не передает (((
[vba]
Код


    ' Линия БОПП
    Range("O9:V9") = Range("B36:I36").Value ' Линия БОПП
    Range("O9:V9").Font.Color = 0
    
    Set ra = Range("O9:V9")     ' диапазон для поиска
    ' минимальный отход
    res = Application.Round(Application.WorksheetFunction.Min(Range("B30:I30")), 0)
    Цвет = -11489280 ' зеленный
    
  Call процедура_раскраски_текста

    res = Application.Round(Application.WorksheetFunction.Max(Range("B30:I30")), 0)
    Цвет = -16777024 ' красный

  Call процедура_раскраски_текста

' и так далее ....
[/vba]


Сообщение отредактировал antycapral - Понедельник, 04.04.2016, 15:19
 
Ответить
СообщениеДень добрый!
Написал небольшую раскраску, на основе готового макроса из РуНета:

[vba]
Код

    Dim ra As Range, cell As Range, res, txt$, v, pos&
    On Error Resume Next: Err.Clear

    ' Линия БОПП
    Range("O9:V9") = Range("B36:I36").Value ' Линия БОПП
    Range("O9:V9").Font.Color = 0
    
    Set ra = Range("O9:V9")     ' диапазон для поиска
    ' минимальный отход
    res = Application.Round(Application.WorksheetFunction.Min(Range("B30:I30")), 0)
    Цвет = -11489280 ' зеленный
    ' процедура раскраски текста
            txt$ = Trim(res)
            For Each cell In ra.Cells    ' перебираем все ячейки
                pos = 1
                If cell.Text Like "*" & txt & "*" Then
                    arr = Split(cell.Text, txt, , vbTextCompare)   ' разбивает текст ячейки на части
                    If UBound(arr) > 0 Then    ' если подстрока найдена
                        For Each v In arr    ' перебираем все вхождения
                            pos = pos + Len(v)    ' начальная позиция
                            With cell.Characters(pos, Len(txt))
                    .Font.Color = Цвет    ' выделяем цветом
                            End With
                            pos = pos + Len(txt)
                        Next v
                    End If
                End If
            Next cell

        ' максимальный отход
        res = Application.Round(Application.WorksheetFunction.Max(Range("B30:I30")), 0)
        Цвет = -16777024 ' красный
        
       ' процедура раскраски текста
            txt$ = Trim(res)
            For Each cell In ra.Cells    ' перебираем все ячейки
                pos = 1
                If cell.Text Like "*" & txt & "*" Then
                    arr = Split(cell.Text, txt, , vbTextCompare)   ' разбивает текст ячейки на части
                    If UBound(arr) > 0 Then    ' если подстрока найдена
                        For Each v In arr    ' перебираем все вхождения
                            pos = pos + Len(v)    ' начальная позиция
                            With cell.Characters(pos, Len(txt))
                    .Font.Color = Цвет    ' выделяем цветом
                            End With
                            pos = pos + Len(txt)
                        Next v
                    End If
                End If
            Next cell
[/vba]

Как мне выделить в отдельное место кода эту процедуру раскраски, чтоб не плодить много букв кода ?
То есть определил в диапазоне макс значение, вызвал процедуру, раскрасил, далее ищем минимальное значение и снова раскраска текста ?

Вот примерный скелет кода, но переменные не передает (((
[vba]
Код


    ' Линия БОПП
    Range("O9:V9") = Range("B36:I36").Value ' Линия БОПП
    Range("O9:V9").Font.Color = 0
    
    Set ra = Range("O9:V9")     ' диапазон для поиска
    ' минимальный отход
    res = Application.Round(Application.WorksheetFunction.Min(Range("B30:I30")), 0)
    Цвет = -11489280 ' зеленный
    
  Call процедура_раскраски_текста

    res = Application.Round(Application.WorksheetFunction.Max(Range("B30:I30")), 0)
    Цвет = -16777024 ' красный

  Call процедура_раскраски_текста

' и так далее ....
[/vba]

Автор - antycapral
Дата добавления - 04.04.2016 в 15:18
Udik Дата: Понедельник, 04.04.2016, 16:00 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 1208
Репутация: 153 ±
Замечаний: 0% ±

Excel 2013
Значения переменных можно передавать либо через глобальные переменные, либо процедуры определять с параметрами.


вот вам барабан
яд 41001231307558 wm R419131876897
udik1968@gmail.com


Сообщение отредактировал Udik - Понедельник, 04.04.2016, 16:05
 
Ответить
СообщениеЗначения переменных можно передавать либо через глобальные переменные, либо процедуры определять с параметрами.

Автор - Udik
Дата добавления - 04.04.2016 в 16:00
Roman777 Дата: Понедельник, 04.04.2016, 16:09 | Сообщение № 3
Группа: Проверенные
Ранг: Ветеран
Сообщений: 703
Репутация: 75 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
Передавать нужно типа такого:
[vba]
Код
Sub процедура_раскраски_текста(res, ra As Range, Цвет)
Dim cell As Range
Dim txt$
Dim v, pos&
    On Error Resume Next: Err.Clear
    ' процедура раскраски текста
            txt$ = Trim(res)
            For Each cell In ra.Cells    ' перебираем все ячейки
                pos = 1
                If cell.Text Like "*" & txt & "*" Then
                    arr = Split(cell.Text, txt, , vbTextCompare)   ' разбивает текст ячейки на части
                    If UBound(arr) > 0 Then    ' если подстрока найдена
                        For Each v In arr    ' перебираем все вхождения
                            pos = pos + Len(v)    ' начальная позиция
                            With cell.Characters(pos, Len(txt))
                    .Font.Color = Цвет    ' выделяем цветом
                            End With
                            pos = pos + Len(txt)
                        Next v
                    End If
                End If
            Next cell
End Sub
[/vba]
[vba]
Код

Sub macr()
Dim ra As Range, res
    ' Линия БОПП
    Range("O9:V9") = Range("B36:I36").Value ' Линия БОПП
    Range("O9:V9").Font.Color = 0
    
    Set ra = Range("O9:V9")     ' диапазон для поиска
    ' минимальный отход
    res = Application.Round(Application.WorksheetFunction.Min(Range("B30:I30")), 0)
    Цвет = -11489280 ' зеленный
    
Call процедура_раскраски_текста(res, ra, Цвет)

    res = Application.Round(Application.WorksheetFunction.Max(Range("B30:I30")), 0)
    Цвет = -16777024 ' красный

Call процедура_раскраски_текста(res, ra, Цвет)

' и так далее ....

End Sub
[/vba]


Много чего не знаю!!!!

Сообщение отредактировал Roman777 - Понедельник, 04.04.2016, 16:10
 
Ответить
СообщениеПередавать нужно типа такого:
[vba]
Код
Sub процедура_раскраски_текста(res, ra As Range, Цвет)
Dim cell As Range
Dim txt$
Dim v, pos&
    On Error Resume Next: Err.Clear
    ' процедура раскраски текста
            txt$ = Trim(res)
            For Each cell In ra.Cells    ' перебираем все ячейки
                pos = 1
                If cell.Text Like "*" & txt & "*" Then
                    arr = Split(cell.Text, txt, , vbTextCompare)   ' разбивает текст ячейки на части
                    If UBound(arr) > 0 Then    ' если подстрока найдена
                        For Each v In arr    ' перебираем все вхождения
                            pos = pos + Len(v)    ' начальная позиция
                            With cell.Characters(pos, Len(txt))
                    .Font.Color = Цвет    ' выделяем цветом
                            End With
                            pos = pos + Len(txt)
                        Next v
                    End If
                End If
            Next cell
End Sub
[/vba]
[vba]
Код

Sub macr()
Dim ra As Range, res
    ' Линия БОПП
    Range("O9:V9") = Range("B36:I36").Value ' Линия БОПП
    Range("O9:V9").Font.Color = 0
    
    Set ra = Range("O9:V9")     ' диапазон для поиска
    ' минимальный отход
    res = Application.Round(Application.WorksheetFunction.Min(Range("B30:I30")), 0)
    Цвет = -11489280 ' зеленный
    
Call процедура_раскраски_текста(res, ra, Цвет)

    res = Application.Round(Application.WorksheetFunction.Max(Range("B30:I30")), 0)
    Цвет = -16777024 ' красный

Call процедура_раскраски_текста(res, ra, Цвет)

' и так далее ....

End Sub
[/vba]

Автор - Roman777
Дата добавления - 04.04.2016 в 16:09
antycapral Дата: Понедельник, 04.04.2016, 16:19 | Сообщение № 4
Группа: Пользователи
Ранг: Участник
Сообщений: 52
Репутация: 5 ±
Замечаний: 0% ±

Excel 2016
Roman777, Заработало !
Я теперь чуточку опытнее в VBA ))) Спасибо, + выслал !
 
Ответить
СообщениеRoman777, Заработало !
Я теперь чуточку опытнее в VBA ))) Спасибо, + выслал !

Автор - antycapral
Дата добавления - 04.04.2016 в 16:19
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Передать переменные в другой макрос, как это реализовать ? (Макросы/Sub)
Страница 1 из 11
Поиск:

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