VBA/Excelのスピードアップ、マクロの追加のチェックボックスが

Question

は、私はいくつかの文書の行ごとにチェックボックスを追加する必要があると私はその作業のためのスクリプトを持って、それは大丈夫だけど。どのように私はそれをスピードアップすることができますか？コード：

Sub AddCheckBoxes() 
    Dim chk As CheckBox 
    Dim myRange As Range, cel As Range 
    Dim ws As Worksheet 

    Set ws = Sheets("") 'adjust sheet to your need 
    Set myRange = ws.Range("A65:A75") ' adjust range to your needs 

    For Each cel In myRange 
     Set chk = ws.CheckBoxes.Add(cel.Left, cel.Top, 30, 6) 'you can adjust left, top, height, width to your needs 
     With chk 
      .Caption = "Valid" 
      .LinkedCell = cel.Range("B65:B75").Address 
     End With 
    Next 
End Sub 

ありがとう！

Answer 1

これを試してみましょう。この目的のために作成した空のブックの通常のコードモジュール（既定では 'Module1'）に次のコードを貼り付けてください。新しいワークブックには存在しないモジュールです。既存のものを使用しないでください。

Option Explicit 

Enum Nws       ' Worksheet rows & columns 
    ' 20 Apr 2017 
    NwsFirstDataRow = 2    ' adjust as required 
            ' Columns: 
    NwsMainData = 1     ' (= A) Test for used range 
    NwsCheck = 7     ' (= G) column for Check cell 
End Enum 

Enum Nck       ' CheckBox 
    ' 20 Apr 2017 
    NckFalse 
    NckTrue 
    NckNotSet      ' any value other than True or False 
End Enum 

Sub SetCheckCell(Target As Range) 
    ' 20 Apr 2017 

    Dim TgtVal As Nck 

    With Target 
     If Len(.Value) Then 
      Select Case .Value 
       Case True 
        TgtVal = NckFalse 
       Case False 
        TgtVal = NckTrue 
       Case Else 
        TgtVal = NckNotSet 
      End Select 
     Else 
      TgtVal = NckNotSet 
     End If 

     If TgtVal = NckNotSet Then 
      SetBorders Target 
      TgtVal = NckFalse 
     End If 

     .Value = CBool(Array(0, -1)(TgtVal)) 
     With .Interior 
      .Pattern = xlSolid 
      .PatternColorIndex = xlAutomatic 
      .ThemeColor = Array(xlThemeColorAccent6, xlThemeColorAccent3)(TgtVal) 
      .TintAndShade = 0.399945066682943 
      .PatternTintAndShade = 0 
     End With 
     .Offset(0, -1).Select 
    End With 
End Sub 

Private Sub SetBorders(Rng As Range) 
    ' 12 Apr 2017 

    Dim Brd As Long 

    For Brd = xlEdgeLeft To xlInsideHorizontal 
     SetBorder Rng, Brd 
    Next Brd 
    Rng.Borders(xlDiagonalDown).LineStyle = xlNone 
    Rng.Borders(xlDiagonalUp).LineStyle = xlNone 
End Sub 

Private Sub SetBorder(Rng As Range, _ 
         Brd As Long) 
    ' 12 Apr 2017 

    With Rng.Borders(Brd) 
     .LineStyle = xlContinuous 
     .ThemeColor = 1 
     .TintAndShade = -0.349986266670736 
     .Weight = xlMedium 
    End With 
End Sub 

列Aに、行10（またはその付近）に何かを入力します。これはワークシートの最後の「使用済み」行です。

今、あなたは最後の「使用」の行を作成したワークシートのコードシートに次のコードを貼り付けます。コードシートでなければなりません。それはすでに存在するシートです。あなたは、VBEのプロジェクトエクスプローラウィンドウのタブの名前でそれを認識します。

Option Explicit 

Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
    ' 20 Apr 2017 

    Dim Rng As Range     ' used range (almost) 
    Dim Rl As Long      ' last row 

    Application.EnableEvents = False 
    With Target.Worksheet 
     Rl = .Cells(.Rows.Count, NwsMainData).End(xlUp).Row 
     Set Rng = .Range(.Cells(NwsFirstDataRow, NwsCheck), .Cells(Rl, NwsCheck)) 
     If Not Application.Intersect(Target, Rng) Is Nothing Then 
      SetCheckCell .Cells(Target.Row, NwsCheck) 
     End If 
    End With 
    Application.EnableEvents = True 
End Sub 

ここでは、テストするように設定されていますが、まずメカニックを理解してください。コードの最初のバッチの先頭には、1行2列を指定するEnum Nwsがあります。指定された行はNwsFirstDataRowであり、割り当てられた値は2です。つまり、行1はこのコードの範囲外です。行1（おそらくキャプション行）をクリックすると、コードは実行されません。 NwsFirstDataRowに値3を設定すると、コードが触れない2つのヘッダー行が作成されます。

2つの列がNwsMainDataとNwsCheckです。 NwsMainDataは最後の行が測定される列です。最後の行の下をクリックすると、コードは実行されません。列Aはあなたのニーズに合わないことがあります。他の値を設定して、別の列を指定することができます。設定した番号は、他の目的ではなく、最後の行を検索するために使用されます。テストでは、列に実際に使用されている行があることを確認します。

NwsCheckはあなたの「チェックボックス」を持つことになります列です。任意の列を指定できます。ちょっと試してみてください。要点は、他の列をクリックするとコードが実行されないことです。したがって、列をクリックすると、コードはNwsFirstDataRow以下で、最後の「使用済み」行以上になると実行されます。クリックを先に進める。

セルが空であるので、それはチェックボックスとして着色し、単語「偽」で埋められます。もう一度クリックすると色が変わり、値はTrueになります。それはトグルし続けます。カーソルが左に移動すると、切り替えることができます。

カーソルを右または上に移動できます。あなたは、Excelが提供している任意の色に色を変更することができます。選択したフレームからフレームを変更することができます。表示されている単語を変更することができます。実際、あなたが変えることができないことはほとんどありません。それは困難ではありません。

質問は、アイデアは、あなたがチェックボックスがやりたい仕事をするために適合させることができるかどうかです。

Answer 2

ここでは上記のバリエーションです。 TRUEまたはFALSEを書く代わりに、実際にチェックされているかどうかのチェックボックス文字を与えます。コードにはステータスを知らせるメッセージボックスが表示されますが、チェックするかどうかに基づいて、代わりに実行したいコードを実行することが考えられます。

このコードをテストするには、この手順を通常のコードモジュールに追加します。上記のコードのいくつかは、この解決策に必要です。テストの目的のために、以前のコード全体をインストールしてください。その後、これを追加します。

Function SetCheck(Cell As Range) As Boolean 
    ' 21 Apr 2017 

    Dim Fun As Integer 
    Dim Chars() As Variant 
    Dim Mark As Integer      ' character current displayed 

    Chars = Array(168, 254)     ' unchecked/checked box 
    With Cell 
     If Len(.Value) Then Mark = AscW(.Value) 
     Fun = IIf(Mark = Int(Chars(0)), 1, 0) 
     With .Font 
      .Name = "Wingdings" 
       .Size = 11 
     End With 
     .Value = ChrW(Chars(Fun)) 
     .Offset(0, 1).Select 
    End With 

    SetCheck = CBool(Fun) 
End Function 

既存のイベントプロシージャを以下のものに置き換えます。違いは分かりますが、迅速なテストのためには、すべてを交換してください。

Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
    ' 21 Apr 2017 

    Dim Rng As Range     ' used range (almost) 
    Dim Rl As Long      ' last row 
    Dim Chk As Boolean 

    Application.EnableEvents = False 
    With Target.Worksheet 
     Rl = .Cells(.Rows.Count, NwsMainData).End(xlUp).Row 
     Set Rng = .Range(.Cells(NwsFirstDataRow, NwsCheck), .Cells(Rl, NwsCheck)) 
     If Not Application.Intersect(Target, Rng) Is Nothing Then 
'   SetCheckCell .Cells(Target.Row, NwsCheck) 
      Chk = SetCheck(Target.Cells(1)) 
      MsgBox "The checkbox is now " & IIf(Chk, "", "un") & "checked" 
     End If 
    End With 
    Application.EnableEvents = True 
End Sub