Soweit der Code für einen alten Fragebogen:
Dieser befindet sich in einer separaten Datei. Es sind also immer drei Dateien um eine Fragebögen auszuwerten: Die Datei mit dem unten stehenden Code, die Zuordnungsmatrix und der Fragebogen..
Jetzt habe ich leider nur keinen Plan wie ich den anpassen darf/ kann/ muss das kein Laufzeitfehler mehr auftaucht
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 = "DSQ"
'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
