Dim t, Datei, DateiNeu, Pfad, b, d
 
Datei = "original.txt" '<--- anpassen
Pfad = "d:\#1\"    '<--- dein Pfad "\" am Ende! 
b = False
b1 = True
Set FSO = CreateObject("Scripting.FileSystemObject")
Set File = FSO.OpenTextFile(Pfad & datei, 1)
 
Do Until File.AtEndOfStream
 
	t = File.ReadLine
	If Left(t, 15) = "[HAUPTPROGRAMM]" And b1 Then 
		b1 = False
		tmp = ""
	End If
 
	If Not b Then
		tmp = tmp & t & vbCrLf
		If Left(t, 14) = "PG_BEZEICHNUNG" Then
		d = Mid(t,InStrRev(t,"=")+1)
			b = True
			Set FileNeu = FSO.OpenTextFile(Pfad & d & ".txt", 2, True)
			fileneu.Write tmp
		End If	
	ElseIf Left(t, 15) = "[HAUPTPROGRAMM]" And b Then 
		b = False
		fileNeu.close
		tmp = ""
		tmp = tmp & t & vbcrlf
	Else
		fileneu.WriteLine t		
	End If
Loop
MsgBox "Fertig"
fileNeu.Close
file.close