Excel evtl. VB Zeichen X zählen und Summe in eine extra Tabelle eintragen

=LÄNGE([Datei1.xls]Tabelle1!A1)

Option Explicit

Sub Zusammenfassen()
Const sSourcePath As String = "Z:\Fragebogendateien" '######## anpassen ########  
Dim wbGes As Workbook, wbTeil As Workbook
Dim fso As Object, oFile As Object
Dim rNext As Integer

Set wbGes = ActiveWorkbook
Set fso = CreateObject("Scripting.FileSystemObject")  

For Each oFile In fso.GetFolder(sSourcePath).Files
    If LCase(Right(oFile.Name, 4)) = ".xls" Then  
        Application.Workbooks.Open (oFile.Path)
        Set wbTeil = ActiveWorkbook
        wbTeil.Worksheets(1).Activate
        Range("A1:A72").Copy '##################### anpassen ####################  
        wbGes.Worksheets(1).Activate
        rNext = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
        ActiveSheet.Cells(rNext, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
        Application.CutCopyMode = False
    End If
    wbTeil.Close
Next

wbGes.Worksheets(1).Activate
Cells.Replace What:="X", Replacement:="1", LookAt:=xlPart, _  
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
Cells.Replace What:="x", Replacement:="1", LookAt:=xlPart, _  
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
wbGes.Save
MsgBox "Fertig."  
End Sub

Option Explicit

Sub Zusammenfassen()
Const sSourcePath As String = "Z:\Fragebogendateien" '######## anpassen ########  
Const intErsteZeile = 3 'der Tabelle mit der Zusammenfassung  
Const intAnzahlFragen = 20
Const intAnzahlAuspr = 6

Dim wbGes As Workbook, wbTeil As Workbook
Dim fso As Object, oFile As Object
Dim intZeile As Integer, i As Integer, j As Integer
Dim strVon As String, strBis As String
Dim astrAntwort(intAnzahlFragen) As String

Set wbGes = ActiveWorkbook
Set fso = CreateObject("Scripting.FileSystemObject")  

For i = 1 To intAnzahlFragen
    With wbGes.Worksheets(1).Cells(intErsteZeile, i + 1)
        .FormulaR1C1 = "Frage" & Chr(10) & CStr(i)  
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlTop
        .ColumnWidth = 5
    End With
Next

intZeile = intErsteZeile + 2
For Each oFile In fso.GetFolder(sSourcePath).Files
    If LCase(Right(oFile.Name, 4)) = ".xls" Then  
        Application.Workbooks.Open (oFile.Path)
        Set wbTeil = ActiveWorkbook
        For i = 1 To intAnzahlFragen
            astrAntwort(i) = ""  
            For j = 1 To intAnzahlAuspr
            If wbTeil.Worksheets(1).Cells(i * 3 + 8, j * 2).Value <> "" Then  
                astrAntwort(i) = astrAntwort(i) & CStr(j)
            End If
            Next
            If astrAntwort(i) = "" Then astrAntwort(i) = "0"  
        Next
        wbGes.Worksheets(1).Cells(intZeile, 1).Value = oFile.Name
        For i = 1 To intAnzahlFragen
            wbGes.Worksheets(1).Cells(intZeile, i + 1).Value = astrAntwort(i)
        Next
    End If
    wbTeil.Close
    intZeile = intZeile + 1
Next

wbGes.Worksheets(1).Activate
With Range(Cells(intErsteZeile + 2, 2), Cells(intZeile - 1, intAnzahlFragen + 1))
    .FormatConditions.Delete
    .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="0"  
    .FormatConditions(1).Interior.ColorIndex = 19
    .FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, Formula1:="6"  
    .FormatConditions(2).Interior.ColorIndex = 34
End With

strVon = "R" & CStr(intErsteZeile + 2) & "C"  
strBis = "R" & CStr(intZeile - 1) & "C"  

For j = 0 To intAnzahlAuspr + 1
    With wbGes.Worksheets(1).Cells(intZeile + 1 + j, 1)
        .Value = j
        .HorizontalAlignment = xlLeft
    End With
    For i = 1 To intAnzahlFragen
        If j <= intAnzahlAuspr Then
            wbGes.Worksheets(1).Cells(intZeile + 1 + j, i + 1).FormulaR1C1 = _
                "=COUNTIF(" & strVon & ":" & strBis & ",RC1)"  
        Else
            wbGes.Worksheets(1).Cells(intZeile + 1 + j, i + 1).FormulaR1C1 = _
                "=COUNTIF(" & strVon & ":" & strBis & ","">=""&RC1)"  
            wbGes.Worksheets(1).Cells(intZeile + 1 + j + 2, i + 1).FormulaR1C1 = _
                "=SUM(R" & CStr(intZeile + 1) & "C:R[-2]C)"  
        End If
    Next
Next

wbGes.Save
MsgBox "Fertig."  
End Sub