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

Вход

Регистрация

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

 

= Мир MS Excel/Изменить наименование макроса или объединить действующий - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Изменить наименование макроса или объединить действующий (Макросы/Sub)
Изменить наименование макроса или объединить действующий
lebensvoll Дата: Пятница, 07.09.2018, 09:57 | Сообщение № 1
Группа: Проверенные
Ранг: Ветеран
Сообщений: 833
Репутация: 15 ±
Замечаний: 0% ±

Excel 2010
Добрейшего Вам утра!!!
Уважаемые форумчане, прошу Вас помочь решить вопрос. Устал биться с девочками, вносят правки и изменения. На вопрос КТО!??? ЭТО НЕ Я ((((
Файл лежит на СЕРВЕРЕ в данном файле есть макрос:
[vba]
Код
    Private Sub Worksheet_Change(ByVal Target As Range)

    Dim lReply As Long
    If Target.Cells.Count > 1 Then Exit Sub
    
    If Not Intersect(Target, Range("E5:E10000")) Is Nothing Then
        If IsEmpty(Target) Then Exit Sub
            If WorksheetFunction.CountIf(Sheets("Контрагент").Range("Контрагент"), Target) = 0 Then
                lReply = MsgBox("Добавить нового КОНТРАГЕНТА " & Target & " в выпадающий список?", vbYesNo + vbQuestion)
                    If lReply = vbYes Then
                        Worksheets("Контрагент").Range("Контрагент").Cells(Worksheets("Контрагент").Range("Контрагент").Rows.Count + 1, 1) = Target
                        Sheets("Контрагент").Range("B1:B1000").Sort Key1:=Sheets("Контрагент").Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
                            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                            DataOption1:=xlSortNormal 'этот код и поможет отсортировать в алфавитном порядке
                    End If
            End If
    End If
    
    If Not Intersect(Target, Range("G5:G10000")) Is Nothing Then
        If IsEmpty(Target) Then Exit Sub
            If WorksheetFunction.CountIf(Sheets("Продукция").Range("Продукция"), Target) = 0 Then
                lReply = MsgBox("Добавить новую ПРОДУКЦИЮ " & Target & " в выпадающий список?", vbYesNo + vbQuestion)
                    If lReply = vbYes Then
                        Worksheets("Продукция").Range("Продукция").Cells(Worksheets("Продукция").Range("Продукция").Rows.Count + 1, 1) = Target
                        Sheets("Продукция").Range("B1:B1000").Sort Key1:=Sheets("Продукция").Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
                            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                            DataOption1:=xlSortNormal 'этот код и поможет отсортировать в алфавитном порядке
                    End If
            End If
    End If
    
End Sub
[/vba]
Нашел на просторах ГУГЛА вот этот макрос:
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) 'макрос отслживания изменений
Dim NewCellValue$, OldComment$
Dim cell As Range
     
    'если ячейка не в отслеживаемом диапазоне, то выходим
    If Intersect(Target, Range("A5:S10000")) Is Nothing Then Exit Sub
     
    'перебираем все ячейки в измененной области
    For Each cell In Intersect(Target, Range("A5:S10000"))
        If IsEmpty(cell) Then
            NewCellValue = "Ячейка очищена" 'фиксируем очистку ячейки
        Else
            NewCellValue = cell.Formula     'или ее содержимое
        End If
        On Error Resume Next
         
        With cell
            OldComment = .Comment.Text & Chr(10)
            .Comment.Delete     'удаляем старое примечание (если было)
            .AddComment         'добавляем новое и вводим в него текст
            .Comment.Text Text:=OldComment & Application.UserName & " " & _
                            Format(Now, "MM.DD.YY h:MM:ss") & " : " & NewCellValue
            .Comment.Shape.TextFrame.AutoSize = True    'делаем автоподбор размера
            .Comment.Shape.TextFrame.Characters.Font.Size = 8
        End With
    Next cell
End Sub
[/vba]
Но КОД начинает ругаться на тот что уже имеется такой же КОД с таким же наименованием
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
[/vba]
Как можно изменить второй код чтоб он начал работать на листе. Или возможно ли объединить два кода в одно, чтоб они не потеряли своей функциональности
Спасибо заранее за отзывчивость и помощь.


Кто бы ты ни был, мир в твоих руках

Сообщение отредактировал lebensvoll - Пятница, 07.09.2018, 10:03
 
Ответить
СообщениеДобрейшего Вам утра!!!
Уважаемые форумчане, прошу Вас помочь решить вопрос. Устал биться с девочками, вносят правки и изменения. На вопрос КТО!??? ЭТО НЕ Я ((((
Файл лежит на СЕРВЕРЕ в данном файле есть макрос:
[vba]
Код
    Private Sub Worksheet_Change(ByVal Target As Range)

    Dim lReply As Long
    If Target.Cells.Count > 1 Then Exit Sub
    
    If Not Intersect(Target, Range("E5:E10000")) Is Nothing Then
        If IsEmpty(Target) Then Exit Sub
            If WorksheetFunction.CountIf(Sheets("Контрагент").Range("Контрагент"), Target) = 0 Then
                lReply = MsgBox("Добавить нового КОНТРАГЕНТА " & Target & " в выпадающий список?", vbYesNo + vbQuestion)
                    If lReply = vbYes Then
                        Worksheets("Контрагент").Range("Контрагент").Cells(Worksheets("Контрагент").Range("Контрагент").Rows.Count + 1, 1) = Target
                        Sheets("Контрагент").Range("B1:B1000").Sort Key1:=Sheets("Контрагент").Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
                            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                            DataOption1:=xlSortNormal 'этот код и поможет отсортировать в алфавитном порядке
                    End If
            End If
    End If
    
    If Not Intersect(Target, Range("G5:G10000")) Is Nothing Then
        If IsEmpty(Target) Then Exit Sub
            If WorksheetFunction.CountIf(Sheets("Продукция").Range("Продукция"), Target) = 0 Then
                lReply = MsgBox("Добавить новую ПРОДУКЦИЮ " & Target & " в выпадающий список?", vbYesNo + vbQuestion)
                    If lReply = vbYes Then
                        Worksheets("Продукция").Range("Продукция").Cells(Worksheets("Продукция").Range("Продукция").Rows.Count + 1, 1) = Target
                        Sheets("Продукция").Range("B1:B1000").Sort Key1:=Sheets("Продукция").Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
                            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                            DataOption1:=xlSortNormal 'этот код и поможет отсортировать в алфавитном порядке
                    End If
            End If
    End If
    
End Sub
[/vba]
Нашел на просторах ГУГЛА вот этот макрос:
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) 'макрос отслживания изменений
Dim NewCellValue$, OldComment$
Dim cell As Range
     
    'если ячейка не в отслеживаемом диапазоне, то выходим
    If Intersect(Target, Range("A5:S10000")) Is Nothing Then Exit Sub
     
    'перебираем все ячейки в измененной области
    For Each cell In Intersect(Target, Range("A5:S10000"))
        If IsEmpty(cell) Then
            NewCellValue = "Ячейка очищена" 'фиксируем очистку ячейки
        Else
            NewCellValue = cell.Formula     'или ее содержимое
        End If
        On Error Resume Next
         
        With cell
            OldComment = .Comment.Text & Chr(10)
            .Comment.Delete     'удаляем старое примечание (если было)
            .AddComment         'добавляем новое и вводим в него текст
            .Comment.Text Text:=OldComment & Application.UserName & " " & _
                            Format(Now, "MM.DD.YY h:MM:ss") & " : " & NewCellValue
            .Comment.Shape.TextFrame.AutoSize = True    'делаем автоподбор размера
            .Comment.Shape.TextFrame.Characters.Font.Size = 8
        End With
    Next cell
End Sub
[/vba]
Но КОД начинает ругаться на тот что уже имеется такой же КОД с таким же наименованием
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
[/vba]
Как можно изменить второй код чтоб он начал работать на листе. Или возможно ли объединить два кода в одно, чтоб они не потеряли своей функциональности
Спасибо заранее за отзывчивость и помощь.

Автор - lebensvoll
Дата добавления - 07.09.2018 в 09:57
_Boroda_ Дата: Пятница, 07.09.2018, 10:06 | Сообщение № 2
Группа: Модераторы
Ранг: Местный житель
Сообщений: 13514
Репутация: 5530 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Держите
Но это не очень хорошая идея. Впрочем, попробуйте сами и, когда не понравится, приходите
К сообщению приложен файл: 78467486186.xlsm(19.0 Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеДержите
Но это не очень хорошая идея. Впрочем, попробуйте сами и, когда не понравится, приходите

Автор - _Boroda_
Дата добавления - 07.09.2018 в 10:06
lebensvoll Дата: Пятница, 07.09.2018, 10:13 | Сообщение № 3
Группа: Проверенные
Ранг: Ветеран
Сообщений: 833
Репутация: 15 ±
Замечаний: 0% ±

Excel 2010
_Boroda_, Александр!!!
А почему это плохая идея!? С чем связано это мнение!?
Так вроде бы работает.... Проверим на действие в работе "процессе"
Спасибо огромнейшее за ответ и помощь


Кто бы ты ни был, мир в твоих руках

Сообщение отредактировал lebensvoll - Пятница, 07.09.2018, 10:19
 
Ответить
Сообщение_Boroda_, Александр!!!
А почему это плохая идея!? С чем связано это мнение!?
Так вроде бы работает.... Проверим на действие в работе "процессе"
Спасибо огромнейшее за ответ и помощь

Автор - lebensvoll
Дата добавления - 07.09.2018 в 10:13
_Boroda_ Дата: Пятница, 07.09.2018, 10:14 | Сообщение № 4
Группа: Модераторы
Ранг: Местный житель
Сообщений: 13514
Репутация: 5530 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
почему это плохая идя!?

это не очень хорошая идея. Впрочем, попробуйте сами


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
Сообщение
почему это плохая идя!?

это не очень хорошая идея. Впрочем, попробуйте сами

Автор - _Boroda_
Дата добавления - 07.09.2018 в 10:14
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Изменить наименование макроса или объединить действующий (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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