23.01.2018, 14:34
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.
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
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 SubAchja Thema Crossposting: http://www.clever-excel-forum.de/thread-13905.html