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 = ""
 For Each rng In rRechteBereich.Rows
  
   
    With rng
    If WorksheetFunction.CountA(rng) > 0 Then

        sZeile = sZeile & .Cells(1, 1).Offset(, -6) & chSep
        sZeile = sZeile & .Cells(1, 1).Offset(, -5) & chSep
        sZeile = sZeile & .Cells(1, 1).Offset(, -4)

        For i = 1 To .Columns.Count

            If Not IsEmpty(.Cells(1, i)) Then

                sZeile = sZeile & chSep & rRoRw.Cells(1, i)
                sZeile = sZeile & chSep & rRoRw.Cells(0, IIf(i Mod 2 = 0, i - 1, i))
            End If
        Next
    End If
    End With
    sZeile = sZeile & vbCrLf
 Next
   
 strPfad = ActiveWorkbook.Path & "\Rechte_" & Format(Date, "ddmmyyyy") & "_" & Format(Time, "hhmmss") & ".txt"

 Call InDateiSchreiben(strPfad, sZeile)

  Application.ScreenUpdating = True
End Sub


Public Sub InDateiSchreiben(Dateipfad As String, _
                            Text As String, _
                            Optional ByVal Anfuegen As Boolean)
 
   'Quelle: http://www.dbwiki.net
 
   Dim d As Integer
 
   d = FreeFile()
 
   If Anfuegen Then  'Text wird an vorhandenen Text angefügt
      Open Dateipfad For Append As d
   Else              'evtl. vorhandener Text wird überschrieben
      Open Dateipfad For Output As d
   End If
 
   Print #d, Text;
 
   Close d
 
End Sub