8

オンライン フォーラムでの一般的な要求は、シート内のロックされていないセルを識別するためのコードです。

標準的なソリューションでは、ループを使用して、アクティブなワークシートの使用部分の各セルを反復処理し、各セルをテストして、ロックされているかどうかを判断します。このアプローチのコード サンプルを以下に示します。

セル範囲をループする際の固有のパフォーマンスの低さを考えると、どのような優れたアプローチが可能ですか?

（注：以前に別のフォーラムでホストされていた独自の既存のアプローチを潜在的なアプローチとして追加するつもりですが、提供されている場合は別の[適切な]方法を回答として受け入れます）

ロックされていないセルを識別するための範囲アプローチ

Sub SelectUnlockedCells()
`http://www.extendoffice.com/documents/excel/1053-excel-identify-select-locked-cells.html
Dim WorkRange As Range
Dim FoundCells As Range
Dim Cell As Range
On Error GoTo SelectUnlockedCells_Error

Set WorkRange = ActiveSheet.UsedRange
For Each Cell In WorkRange
    If Cell.Locked = False Then
        If FoundCells Is Nothing Then
            Set FoundCells = Cell
        Else
            Set FoundCells = Union(FoundCells, Cell)
        End If
    End If
Next Cell
If FoundCells Is Nothing Then
    MsgBox "All cells are locked."
Else
    FoundCells.Select
End If

On Error GoTo 0
Exit Sub

SelectUnlockedCells_Error:
   MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure     
SelectUnlockedCells of Module Module1"
End Sub
4

7 に答える 7

8

SpecialCellsロックされていないセルをすばやく識別するために使用する

以下のコード - QuickUnlocked - は回避策を使用してエラー セルのコレクションをすばやく生成しSpecialCells、ロックされていないセル範囲を識別します。

主なコード手順は次のとおりです。

  • を変更して、Applicationエラー、コード、および画面の更新を抑制します
  • ActiveWorkbookおよび/またはActiveSheetが保護されている場合は、ロックを解除しようとします。失敗した場合はコードを終了します
  • 現在のシートの複製を作成
  • を使用して、レプリカ内の既存の数式エラーを削除します。SpecialCells
  • レプリカ ワークシートを保護し、エラー処理の範囲で、ロックされていないセルのみを入力する意図的な数式エラーを追加します。
  • 結果をクリーンアップして報告する アプリケーション設定をリセットする

SpecialCellsXl2010以前は8192エリア限定の警告

この Microsoft KB の記事に従って、Excel-2007 以前のバージョンでは、VBA マクロを介して最大 8,192 個の連続していないセルがサポートされます。かなり驚くべきことに、VBA マクロを 8192 個を超えるSpecialCells Areas in these Excel versions, will not raise an error message, and the entire area under consideration will be treated as being part of theSpecialCells の範囲コレクションに適用します。

クイックロック解除コード

Sub QuickUnlocked()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim rng3 As Range
    Dim lCalc As Long
    Dim bWorkbookProtected As Boolean

    On Error Resume Next
    'test to see if WorkBook structure is protected
    'if so try to unlock it
    If ActiveWorkbook.ProtectStructure Then
        ActiveWorkbook.Unprotect
        If ActiveWorkbook.ProtectStructure Then
            MsgBox "Sorry, I could not remove the passsword protection from the workbook" _
                 & vbNewLine & "Please remove it before running the code again", vbCritical
            Exit Sub
        Else
            bWorkbookProtected = True
        End If
    End If

    Set ws1 = ActiveSheet
    'test to see if current sheet is protected
    'if so try to unlock it
    If ws1.ProtectContents Then
        ws1.Unprotect
        If ws1.ProtectContents Then
            MsgBox "Sorry, I could not remove the passsword protection from sheet" & vbNewLine & ws1.Name _
                 & vbNewLine & "Please remove it before running the code again", vbCritical
            Exit Sub
        End If
    End If
    On Error GoTo 0

    'disable screenupdating, event code and warning messages.
    'set calculation to manual
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
        lCalc = .Calculation
        .Calculation = xlCalculationManual
    End With

    On Error Resume Next
    'check for existing error cells
    Set rng1 = ws1.Cells.SpecialCells(xlCellTypeFormulas, 16)
    On Error GoTo 0

    'copy the activesheet to a new working sheet
    ws1.Copy After:=Sheets(Sheets.Count)
    Set ws2 = ActiveSheet
    'delete any cells that already contain errors
    If Not rng1 Is Nothing Then ws2.Range(rng1.Address).ClearContents

    'protect the new sheet
    ws2.Protect
    'add an error formula to all unlocked cells in the used range
    'then use SpecialCells to read the unlocked range address
    On Error Resume Next
    ws2.UsedRange.Formula = "=NA()"
    ws2.Unprotect
    Set rng2 = ws2.Cells.SpecialCells(xlCellTypeFormulas, 16)
    Set rng3 = ws1.Range(rng2.Address)
    ws2.Delete
    On Error GoTo 0

    'if WorkBook level protection was removed then reinstall it
    If bWorkbookProtected Then ActiveWorkbook.Protect

    'cleanup user interface and settings
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
        lCalc = .Calculation
    End With

    'inform the user of the unlocked cell range
    If Not rng3 Is Nothing Then
        MsgBox "The unlocked cell range in Sheet " & vbNewLine & ws1.Name & " is " & vbNewLine & rng3.Address(0, 0)
    Else
        MsgBox "No unlocked cells exist in " & ws1.Name
    End If

End Sub
于 2013-06-30T05:46:57.483 に答える
5

Unlockedさて、ループに戻りましたが、この方法は(選択せずに) Nextを使用しているセルのみを参照するため、効率的だと思います。

オブジェクトが範囲の場合、このプロパティは TAB キーをエミュレートしますが、プロパティは次のセルを選択せず​​に返します。

保護されたシートでは、このプロパティは次のロックされていないセルを返します。保護されていないシートでは、このプロパティは常に、指定されたセルのすぐ右にあるセルを返します。

最初の (Next) を保存し、Range.Addressこの最初のものに戻るまで他のものをループします。

Sub GetUnlockedCells_Next()
    Dim ws As Worksheet
    Dim strFirst As String
    Dim rngNext As Range
    Dim strLocked As String

    Set ws = Worksheets(1)
    ws.Protect
    Set rngNext = ws.Range("A1").Next
    strFirst = rngNext.Address
    Do
        strLocked = strLocked & rngNext.Address & ","
        Set rngNext = rngNext.Next
    Loop Until rngNext.Address = strFirst
    strLocked = Left(strLocked, Len(strLocked) - 1)     'remove the spare comma
    ws.Range(strLocked).Select
    ws.Unprotect
    MsgBox strLocked
End Sub
于 2013-06-30T21:29:02.637 に答える
4

条件付き書式を使用する:- 数式を使用して、書式設定するセルを決定する、この数式が当てはまる場合に値を書式設定する:=CELL("protect",A1)=0選択した書式を占有範囲に適用しますか?

于 2013-06-30T06:20:59.577 に答える
1

これは、セルの範囲をループするよりもはるかに高速で、一時的なワークシートなどを複製するよりもはるかに単純で簡単な一般的なソリューションです。Excel VBA の Find メソッドを実行する高速コンパイル コードを利用するため、比較的高速です。が実装されています。

Function GetUnlockedCells(SearchRange As Range) As Range 'Union
    '
    'Finds all unlocked cells in the specified range and returns a range-union of them.
    '
    'AUTHOR: Peter Straton
    '
    '*************************************************************************************************************

    Dim FoundCell As Range
    Dim FirstCellAddr As String
    Dim UnlockedUnion As Range

    'NOTE: When finding by format, you must first set the FindFormat specification:

    With Application.FindFormat
        .Clear
        .Locked = False 'This is the key to this technique
    End With

    'NOTE: Unfortunately, the FindNext method does not remember the SearchFormat:=True specification so it is
    'necessary to capture the address of the first cell found, use the Find method (instead) inside the find-next
    'loop and explicitly terminate the loop when the first-found cell is found a second time.

    With SearchRange
        Set FoundCell = .Find(What:="", After:=.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlPart, _
                              SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, _
                              SearchFormat:=True)
        If Not FoundCell Is Nothing Then
            FirstCellAddr = FoundCell.Address
            Do
'                Debug.Print FoundCell.Address
                If UnlockedUnion Is Nothing Then
                    Set UnlockedUnion = FoundCell.MergeArea                         'Include merged cells, if any
                Else
                    Set UnlockedUnion = Union(UnlockedUnion, FoundCell.MergeArea)   '           "
                End If

                Set FoundCell = .Find(What:="", After:=FoundCell, SearchDirection:=xlNext, SearchFormat:=True)
            Loop Until FoundCell.Address = FirstCellAddr
        End If
    End With
    Application.FindFormat.Clear        'Cleanup

    Set GetUnlockedCells = UnlockedUnion
End Function 'GetUnlockedCells
于 2020-07-03T00:58:14.357 に答える
0

私はこれを調査していましたが、多かれ少なかれ、ブレットのアプローチに一周しました。わずかな違いは、新しいワークシートを作成するのではなく、現在のワークシートを使用することです。また、最初はワークシートにエラーがないと想定しています。(これらを説明するために、Brett のものと同様のコードを追加できます。)

UsedRange「#N/A」でいっぱいになり、エラーを無視Application.Undoして、すぐに元に戻りたいと思っていました。Undo残念ながら（Wordと違って）使えませんでした。そこで、バリアントを使用して領域全体のデータを取得し、それを再挿入することにしました。

Sub GetUnlockedCells()
    Dim ws As Worksheet
    Dim rngUsed As Range
    Dim varKeep As Variant

    Application.ScreenUpdating = False
    Set ws = Worksheets(1)
    ws.Protect
    Set rngUsed = ws.UsedRange
    varKeep = rngUsed.Value
    On Error Resume Next
    rngUsed.Value = "#N/A"
    On Error GoTo 0
    ws.Unprotect
    MsgBox "Unlocked cells are " & _
        rngUsed.SpecialCells(xlCellTypeConstants, xlErrors).Address
    rngUsed.Value = varKeep
    Application.ScreenUpdating = True
End Sub

そのため、残念ながら、私は Brett のクールなコードからはあまり進んでいません。他の誰かに刺激を与えるかもしれませんし、元に戻す方法を発見するかもしれません ;)

数式も失われている (値に変換されている) ため、いくつかの作業が必要です!

于 2013-06-30T20:05:05.463 に答える
0

式がたくさんある場合、一般的なアプローチは

For each row in ...
  lockedR = row.locked
  for each cell in row
     if isnull(lockedR) then ' inconsistent in row
        locked = cell.locked
     else 
        locked = lockedR ' consistent from row, no need to get it.

このパターンは、HasArray などの多くのプロパティでうまく機能します。しかし、Locked の場合だけでも、大幅に (100 倍) 遅くなります。なぜ効率が悪いのかわからない。

Goto Special はかわいいトリックですが、ロックされたセルにはありません。

良い解決策は素晴らしいでしょうが、私は不可能だと思います。

于 2017-12-18T04:43:49.597 に答える