AW: Export in Tab delim txt ohne überflüssige Tabs
15.10.2008 13:44:12
fcs
Hallo Dirk,
das folgende Makro exportiert die Daten aus den ersten beiden Tabellen der Arbeitsmappe zeilenweise in eine Textdatei.
Du muss prüfen, ob für deine Zwecke die Value oder die Text-Eigenschaft der Zellen in die Textdatei geschrieben werden soll und den Code ggf. anpassen.
Gruß
Franz
Sub Text_Export()
'Daten in ersten beiden Tabellen der aktiven Arbeitsmappe in eine Textdatei schreiben
Dim wbActive As Workbook, intI As Integer
Dim varDatei, wks As Worksheet, start As Date
Dim lngZeileLast As Long, lngSpalteMax As Long
Dim lngZeile As Long, intFF As Integer, strText As String
Dim lngSpalte As Long
Const strSep = vbTab 'Trennzeichen zwischen Daten-Spalten
On Error GoTo Fehler
varDatei = Application.GetSaveAsFilename(InitialFileName:="TestExport.txt", _
Filefilter:="Text(*.txt), *.txt", _
Title:="Bitte Namen für Export-Datei wählen oder eingeben und speichern")
If varDatei False Then
start = Now
Set wbActive = ActiveWorkbook
intFF = FreeFile()
Open varDatei For Output As #intFF
For intI = 1 To 2 'Tabellenblatter 1 und 2 abarbeiten
Set wks = wbActive.Worksheets(intI)
With wks
'Letzte Zeile in Blatt ermitteln
lngZeileLast = .UsedRange.Row + .UsedRange.Rows.Count - 1
'Zeilen der Tabelle einlesen
For lngZeile = 1 To lngZeileLast
If lngZeile Mod 500 = 1 Then
Application.StatusBar = wks.Name & " Zeile " & lngZeile & " von " & lngZeileLast
End If
'Letzte Spalte in Zeile ermitteln
lngSpalteMax = .Cells(lngZeile, .Columns.Count).End(xlToLeft).Column
'Wert aus 1. Spalte einlesen
strText = .Cells(lngZeile, 1).Value ' ggf. Text-Eigenschaft
'Werte aus Spalten für Schritte einlesen
For lngSpalte = 2 To lngSpalteMax
strText = strText & strSep & .Cells(lngZeile, lngSpalte).Value 'ggf. Text-Eigenschaft
Next
Print #intFF, strText
Next
End With
Next
Close #intFF
MsgBox "Fertig" & vbLf & "Dauer: " & Format(Now - start, "hh:mm:ss")
End If
Fehler:
If Err.Number 0 Then
Select Case Err.Number
Case 999 '
Case Else
MsgBox "Fehler: " & Err.Number & vbLf & Err.Description
End Select
End If
Application.StatusBar = False
End Sub