Проблема с защитой клеток в Excel

Question

Итак, у меня есть лист Excel с vba-скриптом, который запускается кнопкой. Я прилагаю сценарий ниже. Кроме того, я защитил этот лист паролем, так что только определенные ячейки не защищены, остальные, поскольку они включают формулы, они незащищены. Незащищенные ячейки: B4: C1000, F4: F1000, H4: I1000. Однако каждый раз, когда я запускаю скрипт, все мои незащищенные ячейки снова становятся защищенными, и тогда я не могу ввести в них данные. Интересно, что столбцы F, H, у меня нет этой проблемы. Эта проблема возникает только в B4: C1000. Любая помощь будет оценена. Большое спасибо.

Private Sub CommandButton9_Click()
Dim FileNameAccounts As String
Dim FileNameDaily As String
Dim FileNameExpenses As String
Dim FileNameCashTally As String
Dim FileNameCashCalculator As String
Dim FilePath As String
Dim dt As String
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
Dim FileExt1 As String

Application.ScreenUpdating = False
FilePath = "G:\WASD\Server Data\DailyAccountsFiles\"
dt = Format(Date, "yyyy-mm-dd") & "_" & Format(Time, "hh-mm-ss-AM/PM")
FileNameAccounts = FilePath & dt & "_Accounts"
FileNameDaily = FilePath & dt & "_Outstanding And Deposits"
FileNameExpenses = FilePath & dt & "_Expenses"
FileNameCashTally = FilePath & dt & "_Cash Tally"
FileNameCashCalculator = FilePath & dt & "_Cash Calculator"

Worksheets("Accounts").Activate
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FileNameAccounts      'Exporting the Accounts File

Worksheets("OutstandingAndDeposits").Activate
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FileNameDaily         'Exporting the Outstanding And Deposits File

Worksheets("Expenses").Activate
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FileNameExpenses         'Exporting the Expenses File

Worksheets("CashCalculator").Activate
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FileNameCashCalculator         'Exporting the cash calculator File

Worksheets("CashTally").Activate
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FileNameCashTally         'Exporting the cash tally File

ActiveWorkbook.SaveCopyAs Filename:="G:\WASD\Server Data\DailyAccountsFiles\" & dt & "_Raw_Excel_Data.xlsm"

MkDir "G:\WASD\Server Data\DailyAccountsFiles\" & dt                               'Creating the New Folder to put the files in with the folder being named as per the date

FromPath = "G:\WASD\Server Data\DailyAccountsFiles\"                                'Defining the source path, destination path and the files to move
ToPath = "G:\WASD\Server Data\DailyAccountsFiles\" & dt
FileExt = "*.pdf"
FileExt1 = "*.xlsm"

Set fso = CreateObject("scripting.filesystemobject")                            'Moving Files
fso.MoveFile Source:=FromPath & FileExt, Destination:=ToPath
fso.MoveFile Source:=FromPath & FileExt1, Destination:=ToPath

Sheets("Expenses").Range("B2:D1000").ClearContents                              'Clearing Cells in Expenses Sheet

Worksheets("PS4 Timers").Activate
Sheets("PS4 Timers").Range("A3").ClearContents
Sheets("PS4 Timers").Range("A10").ClearContents
Sheets("PS4 Timers").Range("A17").ClearContents
Sheets("PS4 Timers").Range("A24").ClearContents

Worksheets("Accounts").Activate                                     'Clearing Cells in Accounts Sheet
ActiveSheet.Unprotect "<<<w!a@$3d4>>>"
Sheets("Accounts").Range("B4:C1000").ClearContents
Sheets("Accounts").Range("F4:F1000").ClearContents
Sheets("Accounts").Range("H4:I1000").ClearContents
ActiveSheet.Protect "<<<w!a@$3d4>>>", DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:= _
        True

Worksheets("Expenses").Activate
ActiveSheet.PivotTables("PivotTableExpenses").PivotCache.Refresh

Application.ScreenUpdating = True
Worksheets("Accounts").Activate
ActiveWorkbook.Save

End Sub

Код, указанный ниже, находится на листе «Счета». По сути, когда вы вводите какое-либо имя в столбец B, оно проверяет это имя на листе Outstandings and Deposits и возвращает обратно значение, основанное на выражении if.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim KeyCells As Range
Set KeyCells = Sheets("Accounts").Range("B4:B1000")

Application.ScreenUpdating = False
    If Not Application.Intersect(KeyCells, Range(Target.Address)) _
        Is Nothing Then
        If IsEmpty(Target) Then
        ElseIf IsEmpty(Target.Address) Then
        Else
            Worksheets("OutstandingAndDeposits").Activate                                                 'Updating Table in Outstandings Sheet
            ActiveSheet.PivotTables("PivotTableOutstandings").PivotCache.Refresh

            Dim search_value As Range                                                             ' Get PivotData for the outstandings.
            On Error Resume Next                                                    ' in case there is nothing - there will be an error
            Set search_value = ActiveSheet.PivotTables("PivotTableOutstandings"). _
            GetPivotData("Amount", "Customer", Target)
            On Error GoTo 0                                                               ' if value found - it is assigned to variable
                If Not search_value Is Nothing Then
                    If search_value.Value < 0 Then
                    MsgBox Target & " has Rs." & search_value & " outstanding payment. Clear first"
                    End If
                End If
            Worksheets("Accounts").Activate
        End If
    End If
End Sub

Answer 1

Ваше событие изменения должно выглядеть примерно так:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rng As Range, pt As PivotTable, c As Range
    Dim search_value As Range

    Set rng = Application.Intersect(Me.Range("B4:B1000"), Target)

    If Not rng Is Nothing Then

        If rng.Cells.Count > 10 Then Exit Sub '<< for example

        Set pt = Worksheets("OutstandingAndDeposits").PivotTables( _
                                            "PivotTableOutstandings")    
        pt.PivotCache.Refresh

        For Each c in rng.Cells
            If Len(c.value) > 0 Then
                On Error Resume Next 
                Set search_value = pt.GetPivotData("Amount", "Customer", c.Value)
                On Error GoTo 0                                                               
                If Not search_value Is Nothing Then
                    If search_value.Value < 0 Then
                        MsgBox c.Value & " has Rs." & search_value & _
                                " outstanding payment. Clear first"
                    End If
                End If
            End If 
        Next c

    End If 'cells to process

End Sub

Кроме того, делайте это при очистке ячеек, которые могут вызвать событие

Application.EnableEvents = False
Sheets("Accounts").Range("B4:C1000").ClearContents
Application.EnableEvents = True