Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, cOlZ As Long, strOk As Long, strZ As Long
Dim tMp As Variant
Dim cLr As Boolean
Dim Workbook As Workbook
Set Workbook = ActiveWorkbook
With ThisWorkbook
'ВСТАВЛЯЕМ ТОЛЬКО ЗНАЧЕНИЯ
If Target.Columns.Count > 6 Then Exit Sub
If Cells(1, 1).Value > 0 Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If Application.CutCopyMode Then
Application.EnableEvents = 0
Application.Undo: Target.PasteSpecial xlPasteValues
Application.EnableEvents = -1
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End If
'ТЕКСТ В ЧИСЛА
If Cells(1, 1).Value > 0 Then
Dim rArea As Range
On Error Resume Next ' обработчик ошибок
'ActiveWindow.RangeSelection ' диапазон выбранных ячеек листа даже если выбран графический объект
'ActiveWindow.RangeSelection.SpecialCells(xlCellTypeConstants).Select ' в выбранном диапазоне выделить ячейки с константами _
так будет быстрее, чем обрабатывать все ячейки в Selection
If Err Then Exit Sub ' если нужных ячек не оказалось, то их невозможно выбрать и будет ошибка
With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: End With ' отключаем все замедляющие процедуры
For Each rArea In Selection.Areas 'т.к. выбранными скорее всего окажутся не смежные ячейки, а области, то обрабатывать нужно каждую из областей
rArea.FormulaLocal = rArea.FormulaLocal ' значения во всех ячейках области заменить на них же. При этом произойдёт обновление форматов (это такая не документированная особенность Excel)
Next rArea
With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic: End With ' включаем все обратно в обычный режим.
End If
'УСТАНОВКА ОДИНОЧНОГО КОММЕНТАРИЯ НАЧАЛО
If Target.Columns.Count > 6 Then Exit Sub
If Cells(1, 1).Value = 2 Then
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.DisplayAlerts = True
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim vValue
On Error Resume Next
If Target <> vValue Then Target.Interior.Color = vbGreen
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End If
'УСТАНОВКА ГРУППОВОГО КОММЕНТАРИЯ КОНЕЦ
'УСТАНОВКА ОДИНОЧНОГО КОММЕНТАРИЯ НАЧАЛО2
If Target.Columns.Count > 6 Then Exit Sub
If Sheets("Бюджет").Cells(10, 138).Value = 1 Then
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
ActiveSheet.Unprotect Password:="123"
Dim OldComment As String, NewComment As String, objCell As Range
If Target.Cells.Count = 1 Then
NewComment = Now() & "; " & Application.UserName
If Target.Comment Is Nothing Then
Target.AddComment NewComment
Else
OldComment = Target.Comment.Text
Target.Comment.Text NewComment & vbLf & OldComment
End If
Target.Comment.Shape.TextFrame.AutoSize = True
Target.Comment.Visible = True
DoEvents
Target.Comment.Visible = False
'УСТАНОВКА ОДИНОЧНОГО КОММЕНТАРИЯ КОНЕЦ2
'УСТАНОВКА ГРУППОВОГО КОММЕНТАРИЯ НАЧАЛО2
Else
Set cc = Selection.SpecialCells(xlCellTypeVisible)
For Each c In cc
NewComment = Now() & "; " & Application.UserName
On Error Resume Next
If c.Comment Is Nothing Then
c.AddComment NewComment
Else
OldComment = c.Comment.Text
c.Comment.Text NewComment & vbLf & OldComment
End If
c.Comment.Shape.TextFrame.AutoSize = True
c.Comment.Visible = True
DoEvents
c.Comment.Visible = False
i = i + 1
Next
End If
ActiveSheet.Protect Password:="123", UserInterfaceOnly:=True, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True, AllowFiltering:=True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
End If
'УСТАНОВКА ГРУППОВОГО КОММЕНТАРИЯ КОНЕЦ2
'''''''''''''''''''''''''''''''''''''''''''''''
'ЗАМЕНА ПУСТЫХ НА ДРАНТЯ
If Target.Column = 12 Then
If Target.Value = "" Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
Dim cell As Range 'переменная для перебора ячеек
Dim r As Range 'переменная для диапазона используемых ячеек
For Each cell In Selection
lRow = Cells(Rows.Count, 23).End(xlUp).Row + 1
'lRow = Selection.Row 'первая строка
lLastrowInSelectedRange = Selection.Row + Selection.Rows.Count - 1 'последняя строка
If cell.Value = "" Then
If lLastrowInSelectedRange < lRow Then
cell.Value = "90001676"
End If
End If
Next
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.DisplayAlerts = True
End If
'''''''''''''''''''''''''''''''''''''''''''''''
'ЗАМЕНА НУЛЕЙ И ТЕКСТА
'If Target.Column = 15 Then
'Application.EnableEvents = False
'For Each cel In Target.Cells
' If Application.WorksheetFunction.IsText(cel) Then Application.Undo
' If cel.Value & "" = "0" Then Application.Undo
'Next
'Application.EnableEvents = True
'End If
'''''''''''''''''''''''''''''''''''''''''''''''
If Target.Column <> 58 Then Exit Sub
Dim tx
If Target.Count > 1 Then Exit Sub
If Len(Target.Value) = 0 Then Exit Sub
tx = Split(Target.Value, ",")
For i = LBound(tx) To UBound(tx)
If IsNumeric(tx(i)) Then
If Val(tx(i)) > 12 Or Val(tx(i)) < 1 Then
MsgBox "Ошибка!" & vbCrLf & vbCrLf & "Введите число или числа через запятую от 1 до 12" & vbCrLf & vbCrLf & "Нажмите 'ОК' и повторите"
Exit Sub
End If
End If
Next i
'Dim cell As Range 'переменная для перебора ячеек
' Dim r As Range 'переменная для диапазона используемых ячеек
Set r = Range("BF14:BF10000") 'Все используемые ячейки
For Each cell In r.Cells
'Если один символ справа равен ","
If Right(cell.Value, 1) = "," Then
'замена значения ячейки на то же значение, но без последнего символа
cell.Value = Left(cell.Value, Len(cell.Value) - 1)
End If
Next
'''''''''''''''''''''''''''''''''''''''''''''''''
'СНИМАЕМ АВОФИЛЬТР
Application.ScreenUpdating = False
'Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
Application.Run "Фильтр_очистить"
'''''''''''''''''''''''''''''''''''''''''''''''''
strZ = Target.Row
ActiveSheet.Unprotect Password:="123"
For cOlZ = 32 To 55
If Left(Cells(strZ, cOlZ).Formula, 3) = "=IF" Then Exit For
Next cOlZ
If cOlZ >= 55 Then Exit Sub
strOk = strZ + 1
Do Until (Len(Cells(strOk, cOlZ)) = 0) Or (Left(Cells(strOk, cOlZ).Formula, 3) = "=IF")
strOk = strOk + 1
Loop
strOk = strOk - 1
If cOlZ < 54 Then Range(Cells(strZ, cOlZ + 2), Cells(strOk, 55)).ClearContents
tMp = Split(Application.Substitute(Application.Substitute(Application.Substitute(Target.Value, " ", ""), Application.DecimalSeparator, "."), ",", "."), ".")
If UBound(tMp) < 0 Then Exit Sub
cLr = True
For i = 0 To UBound(tMp)
If (Val(tMp(i)) <= 12) Or (Val(tMp(i)) >= 1) Then
If cOlZ = 32 + 2 * (tMp(i) - 1) Then
cLr = False
Else
Range(Cells(strZ, cOlZ), Cells(strOk, cOlZ + 1)).Copy Cells(strZ, 32 + 2 * (tMp(i) - 1))
End If
End If
Next i
If cLr Then Range(Cells(strZ, cOlZ), Cells(strOk, cOlZ + 1)).ClearContents
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'СТАВИМ АВТОФИЛЬТР С ЗАПОМНЕНЫМИ ЗНАЧЕНИЯМИ
Application.Run "Фильтр_поставить"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ActiveSheet.Protect Password:="123", UserInterfaceOnly:=True, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True, AllowFiltering:=True
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.DisplayAlerts = True
End With
End Sub
|
Идея-то в общем проста и лежит на поверхности. Достаточно в начале кода запуска макроса прописать