TXT File Export

Public Sub Blätter_speichern_txt() Dim ws As Worksheet Dim filename As String Dim my_range As Range Const Pfad As String = "C:\\Home\Documents\Neuer Ordner\" Application.ScreenUpdating = False For Each ws In ThisWorkbook.Worksheets Select Case ws.Name Case "Tabelle1", "Tabelle5" 'ausgenommene Blätter Case Else filename = Pfad & Worksheets("Tabelle1").Range("A1").Value, &? &".txt" Open filename For Output As #1 Set my_range = ? Print #1 Close #1 Application.ScreenUpdating = True MsgBox ("TXT File erstellt!") End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Public Sub Blätter_speichern_txt() Dim ws As Worksheet Dim filename As String, lineText As String Dim my_range As Range Const Pfad As String = "C:\\Home\Documents\Neuer Ordner\" Dim i As Long, j As Long, cnt As Long Dim rngA1 As Range Application.ScreenUpdating = False Set rngA1 = Worksheets("Tabelle1").Range("A1") cnt = 1 For Each ws In ThisWorkbook.Worksheets Select Case ws.Name Case "Tabelle1", "Tabelle5" 'ausgenommene Blätter Case Else filename = Pfad & rngA1.Value & "_" & cnt & ".txt" cnt = cnt + 1 Open filename For Output As #1 With ws Set my_range = Intersect(.UsedRange, .Columns("1:3")) If Not my_range Is Nothing Then For i = 1 To my_range.Rows.Count For j = 1 To my_range.Columns.Count Debug.Print my_range.Cells(i, j) lineText = IIf(j = 1, "", lineText & ",") & my_range.Cells(i, j) Next j Print #1, lineText Next i Close #1 MsgBox ("TXT File erstellt!") End If End With End Select Next Application.ScreenUpdating = True End Sub

Hallo Jay,
Anbei mein Versuch.
Ist zwischen die erste und letzte Zeile in A:C eine Zeile leer, wird sie nicht exportiert. Sollltest Du diese leere Zeile trotzdem exportieren wollen, so füge den 4te Parameter im Aufruf von Daten_exportieren auf "True", also
Daten_exportieren ws, "A:C", cPfad & Worksheets("Tabelle1").Range("A1").Value & "_" & Zaehler & ".txt", True
Für ein bessere Lesbarkeit habe ich Anweisungen, die sich wiederholen (LetzteZeile) oder thematisch trennbar sind (Daten_exportieren), als separate Procedure abgelagert.
Zwar habe ich es getestet, es empflieht sich jedoch zuerst statt "Case Else" einen Case mit nur wenigen Blätter zu probieren.
Ich verwende in Daten_exportieren die Bibliothek "Microsoft Scripting Runtime" (Für Objekt FileSystemObject und TextStream). Diese muss in deinem VBA-Editor unter Extras, Verweise... angebunden werden.


Public Sub Blätter_speichern_txt()
Dim ws As Worksheet
Dim Zaehler As Long
Const cPfad = "C:\Home\Documents\Neuer Ordner\" 'wichtig: abschliessenden "\"
Application.ScreenUpdating = False
Zaehler = 1
For Each ws In ThisWorkbook.Worksheets
Select Case ws.Name
Case "Tabelle1", "Tabelle5" 'ausgenommene Blätter
Case Else
If LetzteZeile(ws, "A:C") Then 'nur wenn nicht leer
Daten_exportieren ws, "A:C", cPfad & Worksheets("Tabelle1").Range("A1").Value & "_" & Zaehler & ".txt"
Zaehler = Zaehler + 1
End If
End Select
Next
Application.ScreenUpdating = True
MsgBox ("Es wurden " & Zaehler - 1 & " txt-Datei(en) erstellt!")
End Sub
Private Sub Daten_exportieren(ByRef Blatt As Worksheet, Bereich As String, DateiName As String, Optional ExportLeereZeile = False)
'Unter Anbindung (Extras, Verweise...) von 'Microsoft Scripting Runtime'
Dim FSO As New FileSystemObject
Dim Datei As TextStream
Dim R
Dim Inhalt As String
Const cTrenn = ";"
Set Datei = FSO.CreateTextFile(DateiName)
For Each R In Blatt.Range(Bereich).Rows("1:" & LetzteZeile(Blatt, Bereich)).Rows
Inhalt = Join(Application.Transpose(Application.Transpose(R)), cTrenn)
If ExportLeereZeile Or Inhalt  String(R.Cells.Count - 1, cTrenn) Then Datei.WriteLine Inhalt
Next
Datei.Close
End Sub
Private Function LetzteZeile(ByRef Blatt As Worksheet, Spalten As String) As Long
Dim Sp
Dim Letzte
For Each Sp In Blatt.Range(Spalten).EntireColumn.Rows(Rows.Count).Cells
Set Letzte = Sp.End(xlUp)
If Letzte.Value  "" And Letzte.Row > LetzteZeile Then LetzteZeile = Letzte.Row
Next
End Function

VG
Yal

Hallo Yal,
Ich danke dir! Läuft alles durch, der Export funktioniert einwandfrei :)
Das einzige Problem das noch besteht, in den Spalten stehen Zahlen es kann z.B. sein, das dort 1,780 steht hier wird nur 1,78 ins txt File exportiert.
Ist es möglich, dass alle Nachkommastellen exportiert werden, selbst wenn diese 0 sind?
Das txt File wird Tabstop getrennt, die Trennung bleibt natürlich gleich egal wieviele Nachkommastellen die jeweilige Zahl hat, jedoch sieht das ganze etwas "unschön" aus wenn die Zahlen mit verschiedenen Nachkommastellen exportiert werden.
Die Daten werden später nochmal eingelesen. Ich möchte hier Fehler vermeiden und daher wenn es geht für alle Daten die gleichen Nachkommastellen exportieren.

Private Sub Daten_exportieren(ByRef Blatt As Worksheet, Bereich As String, DateiName As String, Optional ExportLeereZeile = False) 'Unter Anbindung (Extras, Verweise...) von 'Microsoft Scripting Runtime' Dim FSO As New FileSystemObject Dim Datei As TextStream Dim R, Z Dim Inhalt As String Const cTrenn = vbTab Set Datei = FSO.CreateTextFile(DateiName) For Each R In Blatt.Range(Bereich).Rows("1:" & LetzteZeile(Blatt, Bereich)).Rows Inhalt = "" For Each Z In R.Cells Inhalt = Inhalt & cTrenn & Z.Text Next If ExportLeereZeile Or Inhalt String(R.Cells.Count, cTrenn) Then Datei.WriteLine Mid(Inhalt, Len(cTrenn) + 1) Next Datei.Close End Sub

Public Sub Ersetzten() Dim FileName As String Dim FileContent As String Dim FileFolder As String: FileFolder = ThisWorkbook.Path Dim objFileSystem As Object: Set objFileSystem = CreateObject("Scripting.FileSystemObject") Dim objFile As Object If objFileSystem.FolderExists(FileFolder) Then For Each objFile In objFileSystem.GetFolder(FileFolder).Files If Not objFile.Name = ThisWorkbook.Name Then FileName = objFile.Path FileContent = GetFile(FileName) FileContent = VBA.Replace(FileContent, "1", "2") SaveFile FileName, FileContent End If Next objFile Set objFile = Nothing Set objFileSystem = Nothing Else MsgBox "Kein File gefunden!", vbCritical, FileFolder End If End Sub

Beliebteste Forumthreads (12 Monate)

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread