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)
Dim d As Integer
d = FreeFile()
If Anfuegen Then
Open Dateipfad For Append As d
Else
Open Dateipfad For Output As d
End If
Print #d, Text;
Close d
End Sub