Страницы: 1
RSS
Объединить три действия в одном макросе, срабатывающем при изменении в диапазоне
 
Добрый вечер,

Есть три макроса, нашел их на просторах интернета, в том числе и на этом форуме, скорректировал под свой задачи и вроде все три работают правильно но только по отдельность, не хватает навыков соединить их в один рабочии.

Помогите кто может.
Заранее благодарен!!
Код
Private Sub Worksheet_Change(ByVal Target As Range)
      If Not Intersect(Target, Range("A1:L1048576")) Is Nothing Then
      If Target.Count > 1 Then Exit Sub
      If Target <> "" Then
   ActiveSheet.Unprotect Password:="123"
   Target.Locked = True
   ActiveSheet.Protect Password:="123"
      End If
      End If
End Sub

Код
Private Sub Worksheet_Change(ByVal Target As Range)
      If Target.Cells.Count > 1 Then Exit Sub
   For Each Cell In Target
       If Not Intersect(Cell, Range("J1:J1048576")) Is Nothing Then
     With Range("K" & Cell.Row)
        .Value = DateValue(Now)
          End With
          End If
         Next Cell
End Sub

Код
Private Sub Worksheet_Change(ByVal Target As Range)
       Target = UCase(Target)
End Sub
 
возможно как-то так. Правда не знаю, куда прикрутить ваше  Target = UCase(Target)
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    On Error GoTo errHandler:
    If Not Intersect(Target, Range("A1:L1048576")) Is Nothing Then
        If Target <> "" Then
            ActiveSheet.Unprotect Password:="123"
            Target.Locked = True
            ActiveSheet.Protect Password:="123"
        End If
    End If

    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("J1:J1048576")) Is Nothing Then
        Dim iCell As Range
        Application.EnableEvents = False
        For Each iCell In Target
            With Range("K" & iCell.Row)
                .Value = DateValue(Now)
            End With
        Next iCell
        Application.EnableEvents = True
    End If

errHandler:
    Application.EnableEvents = True
End Sub
Изменено: New - 07.12.2021 23:43:20
 
нужно чтобы буквы стали прописными независимо от того каким регистром они пишутся, может есть другой способ...
эта часть не работает...
Код
If Target.Cells.Count > 1 Then Exit Sub    If Not Intersect(Target, Range("J1:J1048576")) Is Nothing Then
        Dim iCell As Range
        Application.EnableEvents = False
        For Each iCell In Target
            With Range("K" & iCell.Row)
                .Value = DateValue(Now)
            End With
        Next iCell
        Application.EnableEvents = True
    End If
 
без файла и описания задачи - куда вставлять дату, где должны быть прописные буквы и где блокировать сложно корректировать
 
Файл не добавил так как в нём много информации и имеет более 6 Мб, отредактирую чтоб был по меньше и добавлю.  
 
Цитата
макрос для вставки текущей даты, только прописные буквы
Вставка текущей даты и прописные буквы делаются без применения макросов...
 
Oписания задачи по приоритетам.

Есть таблица с данными таблица пополняется практически ежедневно.
    - Нужно чтобы после ввода информации нельзя было изменить
    - Все буквы которые вводится прописные.
    - добавить дату добавления информации.

я вижу это примерно так:
1. блокировать возможность редактирования всех строк таблицы кроме последней, при добавления новой информации таблица расширяется тем самым смещая последнюю строку, остальные можно изменить только при вводе пароля.
2. В столбец "K" вводить дату с условием что соседняя ячейка из столбца "J" не пустая.
3. все что вводится в столбце "B:E" переводить в верхнии регистр.
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Const myPASS = "111"
    
    If Target.Cells.Count = 1 Then
        ActiveSheet.Unprotect myPASS
        ActiveSheet.Cells.Locked = False
        
        With Rows(Target.Row)
            Select Case Target.Column
            Case 2, 3, 4, 5
                Application.EnableEvents = False
                Target.Value = UCase(Target.Value)
                Application.EnableEvents = True
            End Select
            If .Cells(1, [J1].Column).Value = "" Then
                Application.EnableEvents = False
                .Cells(1, [K1].Column).Value = Now
                Application.EnableEvents = True
            End If
        End With
        
        ActiveSheet.ListObjects(1).DataBodyRange.Offset(-1).Cells.Locked = True
        ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:=myPASS
    End If
End Sub

Изменено: МатросНаЗебре - 08.12.2021 14:52:52
 
МатросНаЗебре Проверил, вроде все работает как и хотел, единственное в строке If .Cells(1, [J1].Column).Value <> "" Then поменял = на <> чтобы дата выставлялось после заполнения столбца J

Спасибо вам большое.
Изменено: Vadim Burlac - 08.12.2021 21:36:46
 
Vadim Burlac,
заметьте, что ответ на ваш вопрос поступил не после того как вы набросали разных макросов и пожаловались на невозможность их обьединить
а только после того, как вы описали задачу!

наличие описания задачи (с файлом примером) - это и есть основной залог для получения быстрого и точного ответа на вопрос
Изменено: Ігор Гончаренко - 08.12.2021 22:00:06
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко Я это знаю, и не один раз  так делал и получил решение быстро.

Но я начал искать решение сам, методом проб и ошибок сделал все как нужно но чем больше работал над этим файлом выявлял новые возможности оптимизации.
в итоге добавились вопросы и открыл тему с тем вопросом над которым не мог найти решение, но буду иметь в виду ваше замечание))

Вопрос не по теме но интересно, это как? Регистрация: 01.01.1970
Изменено: Vadim Burlac - 08.12.2021 23:45:03
 
Перепутали немного. Это день рождения )
 
День рождения вроде 25.04.1962
 
Прошел курс омоложения )
 
МатросНаЗебре Добрый день,

Выявил несколько проблем,
    - дата обновляется при каждом изменении ячейке из столбца "J" а так не должно быть.
    - если дата не правильная и исправляю в ручную то срабатывает макрос и ставит текущую дату, так не должно быть.
нужно чтобы макрос ставил дату только при первом заполнении ячейки "J"
я представляю это так: при активации одной ячейки из столбца "K" вставляется дата, при условии что ячейка пустая и также при условии что ячейка из столбца "J"  не пустая.

пробовал внедрить в код пару строк (вставлю ниже) но как оказалось они выключают выполнение макроса и он больше не работает.
Код
    If Target.Column <> 10 Or Target.Row >= 1 And Target.Row <= 2 Then Exit Sub
    If Target.Count > 1 Then Exit Sub

- еще одна проблема в том что в каждом столбце таблицы есть условие на введение данных, но при вводе данных вне таблицы условие не успевает срабатывать  (то есть сначала принимаются введенное значение потом расширяется таблица с условием)
думаю это можно решить если расширять макросом таблицу на одну пустую строку, чтобы всегда была одна пустая строка а при добавление данных в какую либо ячейку из последней строки таблица автоматически расширялась на одну строку, и разблокировать для ввода уже не последнюю строку а последние две.

Спасибо.
 
В этом варианте дата проставляется, если ячейка с датой пустая.
Добавил расширение таблицы при изменении ячейки в столбце J.
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Const myPASS = "111"
     
    If Target.Cells.Count = 1 Then
        ActiveSheet.Unprotect myPASS
        ActiveSheet.Cells.Locked = False
         
        With Rows(Target.Row)
            Select Case Target.Column
            Case 2, 3, 4, 5
                Application.EnableEvents = False
                Target.Value = UCase(Target.Value)
                Application.EnableEvents = True
            End Select
            If .Cells(1, [J1].Column).Value <> "" Then
                With .Cells(1, [K1].Column)
                    If Target.Column <> .Column Then
                        If IsEmpty(.Value) Then
                            Application.EnableEvents = False
                                .Value = Now
                            Application.EnableEvents = True
                        End If
                    End If
                End With
            End If
        End With
         
        With ActiveSheet.ListObjects(1)
            If Target.Column = [J1].Column Then
                If Target.Value <> "" Then
                    If Target.Row = .Range.Row + .Range.Rows.Count - 1 Then
                        Application.EnableEvents = False
                            .Resize .Range.Cells(1).Resize(.Range.Rows.Count + 1, .Range.Columns.Count)
                        Application.EnableEvents = True
                    End If
                End If
            End If
            .DataBodyRange.Offset(-1).Cells.Locked = True
        End With
        
        ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:=myPASS
    End If
End Sub
 
На первый взгляд работает так как и хотел.

Спасибо огромное!
Страницы: 1
Наверх