Sub Textdatei()
Dim sht As Worksheet
Dim loLetzte As Long, i As Long
Dim rng As Range, rRechteBereich As Range, rRoRw As Range
Dim chSep As String
Dim sZeile As String
Dim strPfad As String
Dim strText As String
chSep = ";"
Set sht = ActiveWorkbook.Worksheets("Berechtigung")
loLetzte = sht.Cells(Rows.Count, 1).End(xlUp).Row
Set rRechteBereich = sht.Range("G5:CL" & loLetzte)
Set rRoRw = sht.Range("G4:CL4")
Application.ScreenUpdating = False
sZeile = ""
sZeile = rRoRw.Cells(1, 1).Offset(, -6) & chSep
sZeile = sZeile & rRoRw.Cells(1, 1).Offset(, -5) & chSep
sZeile = sZeile & rRoRw.Cells(1, 1).Offset(, -4) & chSep
sZeile = sZeile & "Berechtigung" & chSep
sZeile = sZeile & "Verzeichnis" & vbCrLf
strPfad = ActiveWorkbook.Path & "\Rechte_" & Format(Date, "ddmmyyyy") & "_" & Format(Time, "hhmmss") & ".txt"
Call InDateiSchreiben(strPfad, sZeile, False)
sZeile = ""
For Each rng In rRechteBereich.Rows
With rng
If WorksheetFunction.CountA(rng) > 0 Then
For i = 1 To .Columns.Count
If Not IsEmpty(.Cells(1, i)) Then
sZeile = sZeile & .Cells(1, 1).Offset(, -6) & chSep
sZeile = sZeile & .Cells(1, 1).Offset(, -5) & chSep
sZeile = sZeile & .Cells(1, 1).Offset(, -4)
sZeile = sZeile & chSep & rRoRw.Cells(1, i)
sZeile = sZeile & chSep & rRoRw.Cells(0, IIf(i Mod 2 = 0, i - 1, i))
sZeile = sZeile & vbCrLf
End If
Next
End If
End With
Next
Call InDateiSchreiben(strPfad, sZeile, True)
Application.ScreenUpdating = True
End Sub