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   'lfd nr
  sZeile = sZeile & rRoRw.Cells(1, 1).Offset(, -5) & chSep   'Surname
  sZeile = sZeile & rRoRw.Cells(1, 1).Offset(, -4) & chSep 'Name
  sZeile = sZeile & "Berechtigung" & chSep 'Berechtigung
  sZeile = sZeile & "Verzeichnis" & vbCrLf ' Verzeichnis
  
  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