So jetzt noch mal richtig,
transponiert werden jeweils alle belegten Spalten.
HTH Nancy
--
Option Explicit
Sub transponse()
Dim startCell As Range, cell1 As Range, cell2 As Range
Dim rowNr&, colNr&, i&, x&
x = Range("A1").CurrentRegion.Rows.Count
For i = 1 To x
Set startCell = Cells(i, 1)
rowNr = startCell.Row: colNr = startCell.Column
If IsEmpty(startCell) Then Exit Sub
' rechtes Zeilenende suchen, Endzelle in zelle1 speichern
For colNr = startCell.Column To 256
If IsEmpty(Cells(rowNr, colNr).Value) Then
Set cell2 = Cells(i, colNr - 1)
Exit For
End If
Next colNr
If cell2 Is Nothing Then Set cell2 = Cells(i, 256)
' den Bereich zwischen startcell und zelle2 markieren
Range(startCell, cell2).Copy
Sheets(2).Select
Dim lastA&
lastA = Range("A65536").End(xlUp).Row
Sheets(2).Cells(lastA + 1, 1).PasteSpecial Paste:=xlAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
Sheets(1).Select
Next i
'now save sheet2 as txt
Dim xlsname As String, txtName As String
xlsname = ActiveWorkbook.FullName
txtName = Left(xlsname, Len(xlsname) - 4) & ".txt"
' Datei löschen, falls sie nicht da ist gäbe es sonst einen Fehler
On Error Resume Next
Kill txtName
On Error GoTo 0
ActiveWorkbook.Sheets(2).SaveAs Filename:=txtName, _
FileFormat:=xlTextPrinter, CreateBackup:=False
End Sub
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP