AW: SaveAs, Problem mit Komma
16.06.2013 19:00:51
Tino
Hallo,
was vergleichbares war vor kurzem hier.
Sub Test_Schreibe_TxT()
Dim sPath$, strZeile$, strTxTFilename$
Dim ArrayData, rngRange As Range, booErste As Boolean
Dim F%
Const strTrennzeichen$ = vbTab
strTxTFilename = "Meine Textdatei.txt"
'Textdatei iwrd im Ordner der Excel gespeichert
sPath = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\")
With ActiveSheet
'Name der TxT-Datei prüfen
If Not LCase(strTxTFilename) Like "*.txt" Then Exit Sub
'kopletter Pfad
sPath = sPath & strTxTFilename
'prüfen ob schon vorhanden --> löschen
If Dir(sPath, vbNormal) <> "" Then Kill sPath
'Datei zum anhängen von Daten öffnen
F = FreeFile
Open sPath For Append As #F
'Bereich in Tabelle Feststellen
Set rngRange = Range("A1", FindLetzte(Sheets(.Name)))
'Bereich Zeilen für Zeile durchlaufen
For Each rngRange In rngRange.Rows
'Zeile in Array Transponieren
ArrayData = Application.Transpose(rngRange)
'Array Transponieren und als Text verketten
ArrayData = Join(Application.Transpose(ArrayData), strTrennzeichen)
'erst ab erster Zeile mit Inhalt schreiben
If Not booErste Then booErste = Replace(ArrayData, strTrennzeichen, "") <> ""
If booErste Then
Print #F, ArrayData
End If
Next rngRange
Close #F
End With
End Sub
Function FindLetzte(mySH As Worksheet) As Range
Dim LRow As Long, LCol As Long
Dim A As Long
With mySH.UsedRange
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 = mySH.Columns(A).Find("*", , xlValues, xlWhole, xlByRows, xlPrevious).Column
LCol = Application.Max(LCol, mySH.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 = mySH.Cells(LRow, LCol)
End Function
Gruß Tino