Tworzenie wspólnej procedury dla grupy jednorodnych kontrolek w Arkuszu.   strona główna:
A po co ten Excel ;-)
 
 
 
     Ten art. ma być podręczną ściągą dot. tematu tworzenia wspólnej procedury dla grupy kontrolek umieszczonych w arkuszu.  
Gdzieś takie gotowe rozwiązania u mnie leżą. Trzeba zebrać je w jednym miejscu. Podać linki do literatury czy wykorzystanych  
metod dot. tematu. Mam nadzieję że nie tylko ja z tego będę korzystał ;-)  
 
Zadanie wyglada następująco:  
   Mamy grupę CheckBox'ów i mają działać jak na załączonym obrazku.  
Po zaznaczeniu danego CheckBox'a wartość z danej kolumny z E:G  
przenosi się do odpowiedniej kolumny z H:J, a po "odznaczeniu" -   
odwrotnie. Tj wartość "wraca na miejsce".  
   Bez względu na Typ wykorzystanych kontrolek wykonanie zadania  
przez proste przypisywanie makra do kontrolki wymagałoby utworzenia  
3x10 prawie identycznych procedur.  
   Jednak istnieją inne sposoby. I o nich własnie dziś mowa :-)  
 
 
 
 
 
 
 
 
Omówimy dwa typy kontrolek:  
                          - Checkbox'y ActiveX                                                              - CheckBox'y z formularzy  
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
Najpierw ActiveX   Introduction To Classes
 
moduł class: ChBoxy   Events And Event Procedures
In VBA
Option Explicit  
 
Public WithEvents xlChBox  As MSForms.CheckBox  
 
Private Sub xlChBox_Click()  
    'Stop  
    Dim xlWks As Excel.Worksheet  
      
    Set xlWks = ThisWorkbook.Worksheets("Arkusz1")  
    Dim arrFrom: arrFrom = VBA.Array("E", "F", "G")  
    Dim arrTo:   arrTo = VBA.Array("H", "I", "J")  
      
    With xlChBox  
        Dim iCol As Integer: iCol = .TopLeftCell.Column - 2  
        If .Value Then  
            xlWks.Range(arrTo(iCol) & .TopLeftCell.Row) = xlWks.Range(arrFrom(iCol) & .TopLeftCell.Row)  
            xlWks.Range(arrFrom(iCol) & .TopLeftCell.Row).Clear  
        Else  
            xlWks.Range(arrFrom(iCol) & .TopLeftCell.Row) = xlWks.Range(arrTo(iCol) & .TopLeftCell.Row)  
            xlWks.Range(arrTo(iCol) & .TopLeftCell.Row).Clear  
        End If  
    End With  
 
End Sub  
 
Private Sub Class_Terminate()  
    Set xlChBox = Nothing  
End Sub  
 
moduł Standardowy:  
Option Explicit  
 
Dim xlChBoxy()   As New ChBoxy  
 
Sub ClassLoad()  
    On Error GoTo ClassLoad_Error  
    Dim xlCtr As Excel.OLEObject  
    Dim xlWks As Excel.Worksheet  
    Dim ostCtrl As Long  
      
    Set xlWks = ThisWorkbook.Worksheets("Arkusz1")  
    For Each xlCtr In xlWks.OLEObjects  
        If TypeName(xlCtr.Object) = "CheckBox" Then  
            ostCtrl = ostCtrl + 1  
            ReDim Preserve xlChBoxy(1 To ostCtrl)  
            Set xlChBoxy(ostCtrl).xlChBox = xlCtr.Object  
        End If  
    Next  
 
ClassLoad_Exit:  
    Set xlCtr = Nothing  
    Set xlWks = Nothing  
    Exit Sub  
 
ClassLoad_Error:  
    MsgBox "Błąd numer: " & Err.Number & vbNewLine & _  
           "Opis: " & Err.Description & vbNewLine & _  
           "Procedura: ClassLoad", vbExclamation  
    Resume ClassLoad_Exit  
End Sub  
 
Sub UnloadClass()  
    Erase xlChBoxy  
End Sub  
 
w mod. Thisworkbook:  
Private Sub Workbook_BeforeClose(Cancel As Boolean)  
    UnloadClass  
End Sub  
 
Private Sub Workbook_Open()  
    ClassLoad  
End Sub  
 
W dwóch słowach:  
     W module class będziemy tworzyć obsługe zdarzeń kontrolek z tablicy xlChBoxy() . Mają to być MSForms.CheckBox'y  
interesuje nas obsługa zdarzenia _Click jednak możemy tu
 
oprogramowac każde inne zdarzenie tej kontrolki.  
Obiekt xlChBox jest publiczną zmienną i trzeba ją niszczyć razem  
z usuwaniem klasy.  
Procedura będzie działac dla kontrolek zapisanych do tablicy  
xlChBoxy(). Tablicę tę trzeba tworzyć każdorazowo po resecie  
pliku - dlatego procedura w Thisworkbook. Przy zamykaniu  
pliku tę publiczną tablicę czyścimy. Co niszczy zapisane tam  
obiekty kontrolek.  
    Przerobienie tej procedury na inny typ kontrolek jest dziecinnie  
łatwe. Dlatego tu ją zapisuję.  
 
 
 
CheckBox'y z formantów formularza  
 
Procedurę pod taką kontrolkę zapisujemy we właściwości OnAction danej kontrolki dlatego wg mnie najlepiej takie kontrolki tworzyć  
programowo.  
 
Sub TworzChboxy()  
    Dim xlWks As Excel.Worksheet  
    Dim rng As Excel.Range  
      
    Set xlWks = ThisWorkbook.Worksheets("Arkusz1")  
    For Each rng In xlWks.[B8:D17]  
        With rng  
            With xlWks.CheckBoxes.Add(.Left, .Top, .Width, .Height)   CheckBoxes.Add Method
                .Caption = vbNullString  
                .OnAction = "ProcStart"   Shape.OnAction Property (Excel)
            End With  
        End With  
    Next  
End Sub  
 
Private Sub ProcStart()  
    Dim xlChBox As Excel.CheckBox  
    Dim xlWks As Excel.Worksheet  
      
    Set xlWks = ThisWorkbook.Worksheets("Arkusz1")  
    Set xlChBox = xlWks.CheckBoxes(Application.Caller)  
      
    Dim arrFrom: arrFrom = VBA.Array("E", "F", "G")  
    Dim arrTo:   arrTo = VBA.Array("H", "I", "J")  
      
    With xlChBox  
        Dim iCol As Integer: iCol = .TopLeftCell.Column - 2  
        If .Value = 1 Then  
            xlWks.Range(arrTo(iCol) & .TopLeftCell.Row) = xlWks.Range(arrFrom(iCol) & .TopLeftCell.Row)  
            xlWks.Range(arrFrom(iCol) & .TopLeftCell.Row).Clear  
        Else  
            xlWks.Range(arrFrom(iCol) & .TopLeftCell.Row) = xlWks.Range(arrTo(iCol) & .TopLeftCell.Row)  
            xlWks.Range(arrTo(iCol) & .TopLeftCell.Row).Clear  
        End If  
    End With  
 
    Set xlChBox = Nothing  
    Set xlWks = Nothing  
 
End Sub  
  Show Hidden Members Command (Object Browser Shortcut Menu)
Co to takiego xlChBox (As Excel.CheckBox) albo xlWks.CheckBoxes?? Takie  
obiekty i ich kolekcje można odnaleźć w Object Browser jak zaznaczym opcję  
"Show Hidden Members" Okaze się że są tam obiekty z formularzy i ich kolekcje,   
metody… Przy tworzeniu tych kontrolek to nieodzowne narzędzie ułatwiające  
pisanie - polecam szczerze :-)  
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
  oba przykłady:
  clschbox.zip