Fragebogen erstellen und auswerten

[Fennek]

Hier st der Code für die Auswertung, eine XLSM-Datei im selben Ordner wie die zurück gesandten Fragebögen:

Code:

Sub Auswertung()
Dim WS As Worksheet: Set WS = ActiveSheet
Dim WB As Workbook
Dim WSZ As Worksheet: Set WSZ = ThisWorkbook.Sheets(1)
Dim Shp As Shape
Dim Grp As GroupShapes
Dim Opt As OptionButton

Pfad = ThisWorkbook.Path & "\"
lr = WSZ.Cells(Rows.Count, 1).End(xlUp).Row

f = Dir(Pfad & "*.xlsx) ' "Fragebogen Felix (Wiede*.xlsx") <<<<<<<<<<<

Do While f <> vbNullString
    lr = lr + 1
    col = 9
    WSZ.Cells(lr, 1) = f
    
    Set WB = GetObject(Pfad & f)
    For sht = 1 To 2
    Set WS = WB.Sheets(sht)
        For Each Shp In WS.Shapes
        'Debug.Print Shp.Top, Shp.TopLeftCell.Address
            
            For i = 1 To Shp.GroupItems.Count
                
                If InStr(1, Shp.GroupItems(i).Name, "Option") > 0 Then
                
                    If Shp.GroupItems(i).ControlFormat.Value = 1 Then
                        WSZ.Cells(lr, col) = i - 1
                        col = col + 1
                    'Debug.Print Shp.TopLeftCell.Offset(, -1), i - 1
                    'Debug.Print i - 1, Shp.TopLeftCell.Address, Shp.GroupItems(i).Name, _
                        Shp.GroupItems(i).ControlFormat.Value
                    End If
                End If
            Next i
        Next Shp
    Next sht
    
    'Freitext
    WSZ.Cells(lr, col) = WB.Sheets(2).Cells(16, 4)
    WSZ.Cells(lr, col + 1) = WB.Sheets(2).Cells(17, 4)
    
    WB.Close 0
f = Dir
Loop
End Sub

Zum Testen müssen die Fragen ausgefüllt sein, aber vor der Verteilung sollte die Buttons wieder auf "xlno" gesetzt werden. In der Datei ist für meinen Test noch der Dateifilter gesetzt. Das musst Du anpassen wie hier gezeigt.

Teste es zuerst mit Dummy-Fragebögen um eventuelle Fehler zu finden.

[Leonhard]

Hallo Fennek,

Was muss ich anpassen damit die erste Zeile der Auswertungsdatei die 3. Zeile ist?
Aktuell wird die 2. Zeile überschrieben, der Rest sieht sonst aber einwandfrei aus :05: :05: :05:

Code:

Sub Auswertung()
Dim WS As Worksheet: Set WS = ActiveSheet
Dim WB As Workbook
Dim WSZ As Worksheet: Set WSZ = ThisWorkbook.Sheets(1)
Dim Shp As Shape
Dim Grp As GroupShapes
Dim Opt As OptionButton

Pfad = ThisWorkbook.Path & "\"
lr = WSZ.Cells(Rows.Count, 1).End(xlUp).Row

f = Dir(Pfad & "*.xlsx") ' "Fragebogen Felix (Wiede*.xlsx")

Do While f <> vbNullString
   lr = lr + 1
   col = 9
   WSZ.Cells(lr, 1) = f
   
   Set WB = GetObject(Pfad & f)
   For sht = 1 To 2
   Set WS = WB.Sheets(sht)
       For Each Shp In WS.Shapes
       'Debug.Print Shp.Top, Shp.TopLeftCell.Address
           
           For i = 1 To Shp.GroupItems.Count
               
               If InStr(1, Shp.GroupItems(i).Name, "Option") > 0 Then
               
                   If Shp.GroupItems(i).ControlFormat.Value = 1 Then
                       WSZ.Cells(lr, col) = i - 1
                       col = col + 1
                   'Debug.Print Shp.TopLeftCell.Offset(, -1), i - 1
                   'Debug.Print i - 1, Shp.TopLeftCell.Address, Shp.GroupItems(i).Name, _
                       Shp.GroupItems(i).ControlFormat.Value
                   End If
               End If
           Next i
       Next Shp
   Next sht
   
   'Freitext
   WSZ.Cells(lr, col) = WB.Sheets(2).Cells(16, 4)
   WSZ.Cells(lr, col + 1) = WB.Sheets(2).Cells(17, 4)
   
   WB.Close 0
f = Dir
Loop
End Sub

[Fennek]

Der Code bestimmt die erste freie Zeile der Spalte A. Am Anfang sollte nur die Überschrift (in Zeile 2?) stehen, dann wird jeder Fragebogen in ein neue Zeile geschrieben.

Die Zeile "lr = ..." bestimmt die letzte belegte Zeile, vor dem Schreiben wird immer 1 addiert.

Die Auswertungen ab Spalte 9 dürfen nicht ohne Dateinamen in Spalte A stehen.

----------

PS: wie verteilst Du die Fragebögen?

[Leonhard]

Das habe ich verstanden. Problem waren die verbundenen Zellen in A1 und A2. Das hat das Makro offensichtlich nicht erkannt und dann die 2 Zeile als frei angesehen.
Der Fragebogen werden wahrscheinlich per Mail verteilt oder auf deren Laufwerk abgelegt.

[snb]

Oder, macro im Macromodul der Tabelle3

[RPP63]

Oder …
(ich melde mich nur noch alle 20 Beiträge)
… man nimmt immer noch die Umfragen nebst Auswertungen, die MS kostenlos zur Verfügung stellt.

OK! Ist nix für smarties, sondern nur für Faule!

*kopfschüttel!*

[snb]

Wenn's kostenlos ist bist du das Produkt. (kopfschüttel bis).