Обнуление незащищенных ячеек файла в заданном диапазоне

range_x = "c16:l37"

sheet_x = "Proba"

For Each r In Workbooks(mybook(0)).Sheets(sheet_x).range(range_x).Cells

If Not r.Locked Then

indrow = r.Row

indcol = r.Column

Workbooks(mybook(0)).Sheets(sheet_x).Cells(indrow, indcol).Value = 0

End if

Next r

___________________________________________________________________

Снятие и установка защиты листа

Workbooks(WorkBookX).Worksheets(NastrSheet).Unprotect (PWD)

Workbooks(WorkBookX).Worksheets(NastrSheet).Cells(1, 16) = 0

Workbooks(WorkBookX).Worksheets(NastrSheet).Protect (PWD)

UserForm2.Hide

___________________________________________________________________

Раскрашивание незащищенных ячеек

RangeX = "C16:L37"

Workbooks(CMyBook).Sheets(SheetX).Activate

Workbooks(CMyBook).Worksheets(SheetX).Unprotect (PWD)

For Each r In Workbooks(CMyBook).Sheets(SheetX).range(RangeX).Cells

indrow = r.row

indcol = r.Column

If Not r.Locked Then

Cells(indrow, indcol).Select

If VarColor <> 0 Then

With Selection.Interior

.ColorIndex = VarColor

.Pattern = xlSolid

.PatternColorIndex = xlAutomatic

End With

End If

Next r

Workbooks(CMyBook).Worksheets(SheetX).Protect (PWD)

__________________________________________________________________________________

Вычисление значений посредством выполнения формул

Sub sortX()

Workbooks("exp1.xls").worksheets("Лист2").Activate

Dim str_x As String

For i = 1 To 3

str_x = "=sum(a" & Trim(Str(i)) & ":c" & Trim(Str(i)) & ")"

Cells(i + 10, 4).Formula = str_x

Next i

End Sub

__________________________________________________________________________________

Сортировка по заданному полю и удаление строки

при наличии одинаковых значений с предыдущей строкой заданного поля

Sub GoodRemoveDuplicates()

worksheets("Лист2").Range("a1").Sort _

key1:=worksheets("Лист2").Range("a1")

Set currentCell = worksheets("Лист2").Range("a1")

Do While Not IsEmpty(currentCell)

Set nextCell = currentCell.Offset(1, 0)

If nextCell.Value = currentCell.Value Then

currentCell.EntireRow.Delete

End If

Set currentCell = nextCell

Loop

End Sub

_______________________________________________________________________________________

Интерактивное задание диапазона ячеек и обработка данных в этих ячейках

Sub RoundToZero()

worksheets("Лист2").Activate

On Error GoTo PressedCancel

Set r = Application.InputBox(prompt:="Select a range of cells", Type:=8)

On Error GoTo 0

For Each c In r.Cells

If Abs(c.Value) > 10 Then

c.Font.ColorIndex = 4

End If

Next c

Exit Sub

PressedCancel:

Resume

End Sub