Есть три макроса, нашел их на просторах интернета, в том числе и на этом форуме, скорректировал под свой задачи и вроде все три работают правильно но только по отдельность, не хватает навыков соединить их в один рабочии.
Помогите кто может. Заранее благодарен!!
Код
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
нужно чтобы буквы стали прописными независимо от того каким регистром они пишутся, может есть другой способ... эта часть не работает...
Код
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
Есть таблица с данными таблица пополняется практически ежедневно. - Нужно чтобы после ввода информации нельзя было изменить - Все буквы которые вводится прописные. - добавить дату добавления информации.
я вижу это примерно так: 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
МатросНаЗебре Проверил, вроде все работает как и хотел, единственное в строке If .Cells(1, [J1].Column).Value <> "" Then поменял = на <> чтобы дата выставлялось после заполнения столбца J
Vadim Burlac, заметьте, что ответ на ваш вопрос поступил не после того как вы набросали разных макросов и пожаловались на невозможность их обьединить а только после того, как вы описали задачу!
наличие описания задачи (с файлом примером) - это и есть основной залог для получения быстрого и точного ответа на вопрос
Ігор Гончаренко Я это знаю, и не один раз так делал и получил решение быстро.
Но я начал искать решение сам, методом проб и ошибок сделал все как нужно но чем больше работал над этим файлом выявлял новые возможности оптимизации. в итоге добавились вопросы и открыл тему с тем вопросом над которым не мог найти решение, но буду иметь в виду ваше замечание))
Вопрос не по теме но интересно, это как? Регистрация: 01.01.1970
Выявил несколько проблем, - дата обновляется при каждом изменении ячейке из столбца "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