checkbox abfragen VBA

[BachFel]

Hallo zusammen,

wie genau ist es möglich eine Checkbox abzufragen?
Falls ein Häkchen gesetzt ist, soll Ja (falls keins gesetzt ist: "")
Das ganze soll dann in folgenden Code eingespeist werden, wobei ich maximal überfordert bin :16:

Die Datei in der die Kontrollkästchen sind heisst: Fragebogen.

Code:

Sub Generieren_Konsolodierunsliste()
   Dim varDatei, varDatei2
   Dim CopyVal() As Variant
   Dim WS As Worksheet
   Dim i As Long
   Dim q As Long
   Dim j As Long
   Dim k As Long
   Dim Ro As Long
   Dim Co As Long
   Dim FBCount As Long
   Dim CurrentPath As String
   Dim FolderPath As String
   Dim Quelle() As String
   Dim ZMatrix As String
   Dim FBogen As String
   Dim fso As FileSystemObject
   Dim fo As Object
   Dim f As Object
   Dim FName() As String
   
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   
   
   CurrentPath = Application.ThisWorkbook.Path
   
   'getting the path of the Zuordnungsmatrix
   MsgBox "Bitte wählen Sie die Excel-Datei mit der Zuordnungsmatrix"
   ChDir CurrentPath
   
   varDatei = Application.GetOpenFilename("Alle Excel-Dateien, *.xl*", 1, "Bitte wählen Sie die Datei mit der Zuordnungsmatrix aus")
   
   If varDatei = False Then
       MsgBox "Sie haben abgebrochen."
       Exit Sub
       'open & acitivate the right sheet in the Zuordnungsmatrix
       Else
           Workbooks.Open (varDatei)
           For Each WS In ActiveWorkbook.Sheets
               If WS.Name = "Zuordnungsmatrix" Then
                   WS.Activate
               End If
           Next WS
   End If
   
   ZMatrix = ActiveWorkbook.Name
   
 
   'select & copy the titles
   i = Cells(Rows.Count, 4).End(xlUp).Row
   Range("D7:D" & i).Select
   Selection.Copy
   'create the new target file
   Workbooks.Add
   ActiveSheet.Name = "Daten"
   'paste the titles on the desired place
   Cells(4, 13).Select
   Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
       xlNone, SkipBlanks:=False, Transpose:=True
   Application.CutCopyMode = False
   With Selection
       .HorizontalAlignment = xlGeneral
       .VerticalAlignment = xlBottom
       .WrapText = True
       .Orientation = 90
       .AddIndent = False
       .IndentLevel = 0
       .ShrinkToFit = False
       .ReadingOrder = xlContext
       .MergeCells = False
   End With
   
   'saveas the target file
   ChDir CurrentPath
   ActiveWorkbook.SaveAs ("Zusammenfassung_Fragebögen-" & Date & ".xlsx")
 
   MsgBox "Bitte wählen Sie eine Excel-Datei im Datenordner"
   ChDir CurrentPath
   
   varDatei = Application.GetOpenFilename("Alle Excel-Dateien, *.xl*", 1, "Bitte wählen Sie eine Datei im Datenordner aus")
   
   If varDatei = False Then
       MsgBox "Sie haben abgebrochen."
       Exit Sub
       'open & acitivate the right sheet in the Zuordnungsmatrix
       Else
           'Workbooks.Open (varDatei)
           Workbooks.Open (varDatei)
           FolderPath = ActiveWorkbook.Path
           ActiveWorkbook.Close
   End If

       'count the number of files to set FBCount
       Set fso = New FileSystemObject
       Set fo = fso.GetFolder(FolderPath)
       
       FBCount = 0
       For Each f In fo.Files
          FBCount = FBCount + 1
       Next 'f
       'MsgBox FBCount & " files found"

       
       'open every file in the folder & do the code
       ReDim Quelle(i - 6)
       ReDim CopyVal(i - 6, FBCount)
       ReDim FName(FBCount)
       
       k = 0
       
       For Each f In fo.Files
           Workbooks.Open f.Path
           FBogen = ActiveWorkbook.Name
           k = k + 1
               FName(k) = FBogen
                               For q = 1 To i - 6
                                   Workbooks(ZMatrix).Sheets("Zuordnungsmatrix").Activate
                                   Quelle(q) = Cells(q + 6, 5)
                                   If Cells(q + 6, 8) <> "" Then
                                       Workbooks(FBogen).Sheets("Fragebogen").Activate
                                       Ro = Range(Quelle(q)).Row
                                       Co = Range(Quelle(q)).Column
                                       For j = 0 To 4
                                           If Cells(Ro, Co + 4 - j) = "x" Or Cells(Ro, Co + 4 - j) = "X" Then
                                               Workbooks(ZMatrix).Sheets("Zuordnungsmatrix").Activate
                                               CopyVal(q, k) = Cells(q + 6, 12 - j)
                                               Exit For
                                           End If
                                           
                                       Next
                                   Else
                                       Workbooks(FBogen).Sheets("Fragebogen").Activate
                                       CopyVal(q, k) = Range(Quelle(q))
                                   End If
                                   
                               Next


           ActiveWorkbook.Close
       Next 'f

   Workbooks(ZMatrix).Close
   
   
   'go to the target file & copy the read data
   Workbooks("Zusammenfassung_Fragebögen-" & Date & ".xlsx").Sheets("Daten").Activate
   For k = 1 To FBCount
       Cells(4 + k, 1) = k 'number of Bogen
       Cells(4 + k, 2) = FName(k) 'name of bogen
       
       For q = 1 To i - 6
           Cells(4 + k, q + 12) = CopyVal(q, k)
       Next
       
       'format copied cells
       Range(Cells(4 + k, 1), Cells(4 + k, i + 6)).Select
       With Selection
           .HorizontalAlignment = xlGeneral
           .VerticalAlignment = xlBottom
           .WrapText = False
           .Orientation = 0
           .AddIndent = False
           .IndentLevel = 0
           .ShrinkToFit = False
           .ReadingOrder = xlContext
           .MergeCells = False
       End With
   Next
   
   
   
   
   'save & close the target file
   ActiveWorkbook.Save
   ActiveWorkbook.Close
   
   MsgBox FBCount & " Fragebögen zusammengefasst"

End Sub

Ich hoffe sehr das sich jemand dem annehmen kann & mir evtl einen Rat gibt wie man das lösen könnte.
Achja Thema Crossposting: http://www.clever-excel-forum.de/thread-13905.html

[Igelbauer]

Hi
Dem Code nach zu urteilen bist du ja nicht mehr ganz unbedarft.
Checkbox.Value gibt entweder den Wert "False" (kein Häkchen), oder True (Häkchen gesetzt) zurück.
Wenn du also in den Code einbaust
If Userform.Checkbox.Value = True then .....  (Bezeichnungen natürlich anpassen)
kannst du es im Code weiterverarbeiten.

Gruss Igel

[BachFel]

Code:

Option Explicit

Sub Generieren_Konsolodierunsliste()
    Dim varDatei, varDatei2
    Dim CopyVal() As Variant
    Dim WS As Worksheet
    Dim i As Long
    Dim q As Long
    Dim j As Long
    Dim k As Long
    Dim Ro As Long
    Dim Co As Long
    Dim FBCount As Long
    Dim CurrentPath As String
    Dim FolderPath As String
    Dim Quelle() As String
    Dim ZMatrix As String
    Dim FBogen As String
    Dim fso As FileSystemObject
    Dim fo As Object
    Dim f As Object
    Dim FName() As String
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
   
    CurrentPath = Application.ThisWorkbook.Path
   
    'getting the path of the Zuordnungsmatrix
    MsgBox "Bitte wählen Sie die Excel-Datei mit der Zuordnungsmatrix"
    ChDir CurrentPath
   
    varDatei = Application.GetOpenFilename("Alle Excel-Dateien, *.xl*", 1, "Bitte wählen Sie die Datei mit der Zuordnungsmatrix aus")
   
    If varDatei = False Then
        MsgBox "Sie haben abgebrochen."
        Exit Sub
        'open & acitivate the right sheet in the Zuordnungsmatrix
        Else
            Workbooks.Open (varDatei)
            For Each WS In ActiveWorkbook.Sheets
                If WS.Name = "Zuordnungsmatrix" Then
                    WS.Activate
                End If
            Next WS
    End If
   
    ZMatrix = ActiveWorkbook.Name
   
  
    'select & copy the titles
    i = Cells(Rows.Count, 4).End(xlUp).Row
    Range("D7:D" & i).Select
    Selection.Copy
    'create the new target file
    Workbooks.Add
    ActiveSheet.Name = "Daten"
    'paste the titles on the desired place
    Cells(4, 13).Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=True
    Application.CutCopyMode = False
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 90
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
   
    'saveas the target file
    ChDir CurrentPath
    ActiveWorkbook.SaveAs ("Zusammenfassung_Fragebögen-" & Date & ".xlsx")
   
   
     'getting the path of the Folder with files
'    MsgBox "Bitte wählen Sie den Ordner der Fragebögen"
'    ChDir CurrentPath
'
'     Dim AppShell As Object
'     Dim BrowseDir As Variant
'     Dim FolderPath As String
'
'     Set AppShell = CreateObject("Shell.Application")
'     Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen", &H1000, 17)
'     On Error Resume Next
'     FolderPath = BrowseDir.items().Item().Path
'     If FolderPath = "" Then Exit Sub
'     On Error GoTo 0
    
        'getting the path of the Folder through selecting a file in the folder
    MsgBox "Bitte wählen Sie eine Excel-Datei im Datenordner"
    ChDir CurrentPath
   
    varDatei = Application.GetOpenFilename("Alle Excel-Dateien, *.xl*", 1, "Bitte wählen Sie eine Datei im Datenordner aus")
   
    If varDatei = False Then
        MsgBox "Sie haben abgebrochen."
        Exit Sub
        'open & acitivate the right sheet in the Zuordnungsmatrix
        Else
            'Workbooks.Open (varDatei)
            Workbooks.Open (varDatei)
            FolderPath = ActiveWorkbook.Path
            ActiveWorkbook.Close
    End If
        'count the number of files to set FBCount
        Set fso = New FileSystemObject
        Set fo = fso.GetFolder(FolderPath)
       
        FBCount = 0
        For Each f In fo.Files
           FBCount = FBCount + 1
        Next 'f
        'MsgBox FBCount & " files found"
       
        'open every file in the folder & do the code
        ReDim Quelle(i - 6)
        ReDim CopyVal(i - 6, FBCount)
        ReDim FName(FBCount)
       
        k = 0
       
        For Each f In fo.Files
            Workbooks.Open f.Path
            FBogen = ActiveWorkbook.Name
            k = k + 1
                FName(k) = FBogen
                                For q = 1 To i - 6
                                    Workbooks(ZMatrix).Sheets("Zuordnungsmatrix").Activate
                                    Quelle(q) = Cells(q + 6, 5)
                                    If Cells(q + 6, 8) <> "" Then
                                        Workbooks(FBogen).Sheets("Fragebogen").Activate
                                        Ro = Range(Quelle(q)).Row
                                        Co = Range(Quelle(q)).Column
                                        For j = 0 To 4
                                            If Cells(Ro, Co + 4 - j) = "x" Or Cells(Ro, Co + 4 - j) = "X" Then
                                                Workbooks(ZMatrix).Sheets("Zuordnungsmatrix").Activate
                                                CopyVal(q, k) = Cells(q + 6, 12 - j)
                                                Exit For
                                            End If
                                           
                                        Next
                                    Else
                                        Workbooks(FBogen).Sheets("Fragebogen").Activate
                                        CopyVal(q, k) = Range(Quelle(q))
                                    End If
                                   
                                Next

            ActiveWorkbook.Close
        Next 'f
    Workbooks(ZMatrix).Close
   
   
    'go to the target file & copy the read data
    Workbooks("Zusammenfassung_Fragebögen-" & Date & ".xlsx").Sheets("Daten").Activate
    For k = 1 To FBCount
        Cells(4 + k, 1) = k 'number of Bogen
        Cells(4 + k, 2) = FName(k) 'name of bogen
       
        For q = 1 To i - 6
            Cells(4 + k, q + 12) = CopyVal(q, k)
        Next
       
        'format copied cells
        Range(Cells(4 + k, 1), Cells(4 + k, i + 6)).Select
        With Selection
            .HorizontalAlignment = xlGeneral
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
        End With
    Next
   
   
    'save & close the target file
    ActiveWorkbook.Save
    ActiveWorkbook.Close
   
    MsgBox FBCount & " Fragebögen zusammengefasst"
End Sub



Oh Gott, mittlerweile habe ich ein ganz anders Problem:

bekomme den Laufzeitfehler Methode Range für das Objekt global fehlgeschlagen rein =////
ich lade Hierzu mal die Zuordnungsmatrix und den Fragebogen hoch die durch den Code angesteuert wird. Ich hoffe sehr das mir jemand helfen kann, ich verzweifle gleich :22:

[Fennek]

Hallo,

der Umfang mag für eine interne Marktforschung gehen, aber die Auswertung ist eher etwas für xl-Spezialisten.

mfg

[Fennek]

Hallo,

im vorliegenden Frageboge gibt es Problem mit den Check-Boxen.

Frage:

Sind die Fragebögen bereits verteilt, oder kann die Vorlage noch geändert werden?



mfg

[Fennek]

Hallo,

in vorgelegten Fragebogen sind einige Checkboxen doppelt und vollständig übereinandergelegt.

Generell ist es nicht ratsam, die CheckBoxen von Hand anzulegen. Es ist zu fehleranfällig und (fast) nicht mehr editierbar.

Mit einem Makro geht es aber sehr gut!

Falls es geplant ist den Fragebogen als xlsx-Datei zu verschicken, muss das Blatt gegen Fehleingaben geschützt werden. Auch das ist möglich.

Da die CheckBoxen von Hand (chaotisch) angelegt wurden, ist die Auswertung kritisch. Aber falls die Liste in der Datei "Zuordnung" gut gepfegt wird, ist auch die Auswertung recht einfach.

mfg

[schauan]

Hallöchen,

wenn Du auf dem Blatt Chexkboxen von den Formular-Steuerelementen hast, funktioniert Checkbox1.Value nicht.

Hier nimmst Du entweder den direkten Weg, z.B.
ActiveSheet.Shapes("Check Box 1").OLEFormat.Object.Value
Allerdings, wie Fennek schon schreibt, ist Deine Checkbox-Reihenfolge ...

Da kommt dann noch die Sache mit den deutschen und englischen Namen dazu ... Der Rollstuhlfahrer ist z.B. Kontrollkästchen 44, Checkbox 44 würde hier das falsche Ergebnis bringen. Kannst den mal anhakeln und testen mit
Msgbox ActiveSheet.Shapes("Check Box 44").OLEFormat.Object.Value & vbtab & _
ActiveSheet.Shapes("Kontrollkästchen 44").OLEFormat.Object.Value

Alternativ nimmst Du den "bekannteren" Weg und richtest eine Zellverknüpfung ein und fragst dann die Zellinhalte ab.