AW: Nachfrage..
11.09.2018 14:19:10
UweD
so?
Modul1
Option Explicit
Sub Texten()
Dim TB, LR As Long, LC As Integer, Sp As Integer, Z1 As Integer, i As Long
Dim Pfad As String
Set TB = Sheets("Tabelle1") 'Blatt mit den Daten
Sp = 1 'Spalte A
Z1 = 2 'wegen Überschrift
Pfad = "X:\Temp\"
Pfad = Pfad & IIf(Right(Pfad, 1) = "\", "", "\") 'Prüfen ob \ am Ende
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
LR = TB.Cells(TB.Rows.Count, Sp).End(xlUp).Row 'letzte Zeile der Spalte
For i = Z1 To LR
LC = TB.Cells(i, TB.Columns.Count).End(xlToLeft).Column 'letzte Spalte einer Zeile
'neues Blatt anlegen
Sheets.Add After:=Sheets(Sheets.Count)
With ActiveSheet
'Werte transponiert in Neues Blatt kopieren
.Cells(1, 1).Resize(LC - Sp + 1, 1) = _
WorksheetFunction.Transpose(TB.Cells(i, Sp + 1).Resize(1, LC - Sp + 1))
'Blatt separieren als eigene Datei
.Move
'Speichern als TXT und Schließen.
'Dateien werden ohne Nachfrage überschrieben, wenn schon vorhanden
ActiveWorkbook.SaveAs Filename:=Pfad & TB.Cells(i, Sp) & ".txt", FileFormat:= _
xlTextMSDOS, CreateBackup:=False
ActiveWorkbook.Close False
End With
Next
TB.Activate
Application.DisplayAlerts = True
MsgBox "Fertig"
End Sub
LG UweD