---

Hallo Leute,

ich möchte gerne aus einer Ecxel datei die Daten in ein mein.txt
Exportieren. Habe dies auch mit einem Macro aus einem anderem Forum hinbekommen. Ich hätte aber gerne das ganze nicht in einer Reihe sonder untereinander.
Jetzt kommt es so als mein.txt

A1;A2;A3;A4;
B1;B2;B3;B4;  usw

ich hätte gerne das ganze so
A1
A2
A3
A4
B1
B2
B3
B4
usw.

wenn dies möglich wäre.

das wo ich schon habe Sieht so aus

Sub ascii_datei_exportieren()
Dim lngZeile As Long
Dim lngZcnt As Long
Dim intSpalte As Integer
Dim intScnt As Integer
Dim strText As String
Dim strSep As String
Dim sFile As String
Dim strName As String
lngZcnt = Sheets("TB1").Range("A300").End(xlUp).Row  'Zeilenanzahl >Tabellenname anpassen
intScnt = 7              'Spaltenanzahl
strSep = ";"              'Trennzeichen = ;
strName = "Neuetest"  'Name der Textdatei
Close #1
'Name und Speicherort festlegen
sFile = "C:\" & strName & Format(Date, "ddmmyy") & ".txt"  'Pfad anpassen
'Öffnen der strTextdatei
Open sFile For Output As 1
 
'Schleife fürlngZeilen
  For lngZeile = 2 To lngZcnt  'ab Zeile 2
  strText = ""
  'Schleife für intSpalten
      For intSpalte = 1 To intScnt
      strText = strText & CVar(Cells(lngZeile, intSpalte))
        If intSpalte < intScnt Then strText = strText & strSep
      Next
      If lngZeile = lngZcnt Then Print #1, strText; Else Print #1, strText
  Next
 
'Schließen der Textdatei
Close #1
End Sub

kann dies vielleicht jemand abändern das es als txt-datei so
exportiert wird wie ich es gerne hätte

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Garry,

welcome by 'herber' 

Ich denke mal 'Transponieren' ist das was Du brauchst,
würde dies dann über eine Art Hilfsheet lösen

Du kannst das einfach mal probieren, markiere deine Zellen zB A1 bis A4 > kopieren, Sheet(2) A1 Inhalte einfügen und hierbei transponieren anhaken

Idee ist also folgende, Zeile für zeile,kopieren & transponieren untereinander in sheet2 und sheet 2 dann als txt saven.

Um dies automatisiert zu tun, nun gebe zu, da habe ich mich momentan selber verhakelt.

Gutes Rutschen
lg Nancy

[Diese Nachricht wurde von startrek am 01. Jan. 2004 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

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