シート上のループスルーチェックボックス

Question

ループとして以下をどのように作成しますか。

基本的にループへの最初のリストはselectStatus、selectSite、これらはシート上のチェックボックスあるだろう。 （下のコードには2つしか含まれていませんが、完全なマクロには約60のループがあります）

2番目のループは "Header 1"、 "Header 2"などの値になります。最初のものはチェックボックス名で、2番目は対応するSQLヘッダーで、最後に文字列を作成します。

Sub TEST2() 

    If Sheets("controlSheet").selectStatus.Value = True Then 
    a = "Header 1, " 
    Else 
    a = "" 
    End If 

    If Sheets("controlSheet").selectSite.Value = True Then 
    a = a + "Header 2, " 
    Else 
    a = a + "" 
    End If 

    End Sub 

Answer 1

ここで、コントロール名とヘッダー名の間のマッピングのリストを保持するオブジェクトを作成できるヘッダーが1つあります。質問があれば教えてください。

オブジェクト

Function GetHeaders() As Object 
    If oDictHeaders Is Nothing Then 
     Set oDictHeaders = CreateObject("Scripting.Dictionary") 

     oDictHeaders("SelectSite") = "Header 1" 
     oDictHeaders("SelectStatus") = "Header 2" 
     oDictHeaders("SelectOther") = "Header 3" 
    End If 

    Set GetHeaders = oDictHeaders 
End Function 


Function GetListOfHeaders() As String 
    Dim sOutput As String 
    Dim oDict As Object 
    Dim ctl As Object 

    sOutput = "" 

    Set oDict = GetHeaders() 

    For Each ctl In Sheet1.OLEObjects 
    Debug.Print TypeName(ctl.Object) 
     If TypeName(ctl.Object) = "CheckBox" Then 
      If ctl.Object.Value = True Then 
       sOutput = sOutput & ", " & oDict(ctl.Name) 
      End If 
     End If 
    Next ctl 

    GetListOfHeaders = Mid(sOutput, 2) 
End Function 

Sub Test() 
    MsgBox (GetListOfHeaders()) 
End Sub 

Answer 2

これは、ActiveXチェックボックスを処理する必要があります。

注：これが（つまり、インデックスによって最初 1は、「ヘッダ1」、「ヘッダ2」と第二、ヘッダー」とN番目に対応させていただきますあなたのチェックボックスが正しくインデックス付けされている必要がありn "など）。それらが故障している場合は、それを制御する追加のロジックが必要です（その場合はthe other answer for a good solutionを参照）。

Option Explicit 
Sub LoopActiveXCheckBoxes() 

Dim ws As Worksheet 
Dim obj As OLEObject 
Dim cb As CheckBox 
Dim i As Long 
Dim a As String 

Set ws = Sheets("controlSheet") 
For Each obj In ws.OLEObjects 
    If TypeName(obj.Object) = "CheckBox" Then 
     i = i + 1 
     If obj.Object.Value = True Then 
      a = a & "Header " & CStr(i) & "," 
     End If 
    End If 
Next 
If Len(a) > 0 Then a = Left(a, Len(a) - 1) 

End Sub 

フォームコントロールのチェックボックスの場合、これは機能しますが、私はあなたがActiveXを使用していると確信しています。

Sub LoopCheckBoxes() 

Dim ws As Worksheet 
Dim cb As CheckBox 
Dim i As Long 
Dim a As String 

Set ws = Sheets("controlSheet") 
For Each cb In ws.CheckBoxes 
    i = i + 1 
    If cb.Value = 1 Then 
     a = a & "Header " & CStr(i) & "," 
    End If 
Next 
If Len(a) > 0 Then a = Left(a, Len(a) - 1) 

End Sub