AW: als txt abspeichern, erste Spalte leer
07.11.2015 10:52:05
Tino
Hallo,
kannst mal diese Version testen.
Option Explicit
Sub SaveTXT()
Dim ArData
Dim rngRange As Range
Dim sText$, SaveTxTPath$
Dim F%
Dim n&, nn&
'Pfad für Textdatei, evtl. anpassen
SaveTxTPath = ThisWorkbook.FullName
SaveTxTPath = Left$(SaveTxTPath, InStrRev(SaveTxTPath, "."))
SaveTxTPath = SaveTxTPath & "txt"
'Textdatei vorhanden -> löschen
If Dir(SaveTxTPath) <> "" Then Kill SaveTxTPath
With Tabelle1 'Tabelle evtl. anpassen
Set rngRange = .Range("A1", FindLetzte(.UsedRange))
If rngRange.Cells.Count > 1 Then
ArData = rngRange
Else
If rngRange.Value <> "" Then
ArData = rngRange.Resize(, 2)
Redim Preserve ArData(1 To 1, 1 To 1)
Else
MsgBox "keine Daten in der Tabelle gefunden!", vbExclamation
Exit Sub
End If
End If
End With
With Application
F = FreeFile
Open SaveTxTPath For Append As #F
If Ubound(ArData) > 1 Then
For n = 1 To Ubound(ArData)
sText = Join(.Index(ArData, n), vbTab)
Print #F, sText
sText = ""
Next n
Else
For nn = 1 To Ubound(ArData, 2)
sText = sText & ArData(1, nn) & vbTab
Next nn
sText = Left$(sText, Len(sText) - 1)
Print #F, sText
End If
Close #F
End With
End Sub
Function FindLetzte(myRange As Range) As Range
Dim LRow As Long, LCol As Long
Dim A As Long
With myRange
On Error Resume Next
'Finde Zeile
LRow = .Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False, False).Row
LRow = Application.Max(LRow, .Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Row)
If LRow = 0 Then LRow = 1
'Finde Spalte
For A = .Columns(.Columns.Count).Column To .Columns(1).Column Step -1
LCol = .Parent.Columns(A).Find("*", , xlValues, xlWhole, xlByRows, xlPrevious).Column
LCol = Application.Max(LCol, .Parent.Columns(A).Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Column)
If LCol > 1 Then: LCol = A: Exit For
Next A
If LCol = 0 Then LCol = 1
End With
Set FindLetzte = myRange.Parent.Cells(LRow, LCol)
End Function
Gruß Tino