'*******************************************************************
Sub CsvAlsSeriellesTextfileSpeichern()
'*******************************************************************
->1. Prüfung csv-file
->1.1 wenn nein -> Meldung -> Exit
->2. beschriebenen Bereich der csv-Datei bestimmen
->2.1 erste/letzte beschriebene Spalte/Zeile
->2.2 wenn Blatt leer, Meldung -> Exit
->3. Pfad und Dateinamen der aktiven Mappe (csv-Datei) bestimmen
->4. Serielle Textdatei neu anlegen
-> (gleicher Pfad, Dateiname, Endung txt)
->4.1 Prüfen, ob file bereits existiert
->4.1.1 wenn ja, fragen auf Überschreiben
->4.1.1.1 nein -> Abbruch
->5. Zellinhalt des beschriebenen Bereichs zeilenweise
-> in Textdatei schreiben, abschliessen mit Linefeed
->6. Textdatei schliessen
->7. Vollzug melden
->8. Aufräumen
'*******************************************************************
Dim wb As Workbook, ws As Worksheet
Dim l_row_first As Long, l_row_last As Long, l_col_first As Long, l_col_last As Long
Dim my_path As String, my_name As String, my_newname As String, my_file As String
Dim ret As Integer, s As Long, z As Long
Set wb = ActiveWorkbook
Set ws = ActiveSheet
->1. Prüfung csv-file
If Right(ActiveWorkbook.Name, 4) <> .csv Then
->1.1 wenn nein -> Meldung -> Exit
MsgBox (Aktive Datei keine cvs-Datei! & vbLf & Ende der Bearbeitung :-()
Exit Sub
End If
->2. beschriebenen Bereich der csv-Datei bestimmen
->2.1 erste/letzte beschriebene Spalte/Zeile
->2.2 wenn Blatt leer, Meldung -> Exit
If Not CSV_Matrix_bestimmen(ws, l_row_first, l_row_last, _
l_col_first, l_col_last) Then
MsgBox (Blatt enthält keinen Inhalt & vbLf & Ende der Bearbeitung :-()
Exit Sub
End If
->3. Pfad und Dateinamen der aktiven Mappe (csv-Datei) bestimmen
my_path = wb.Path
my_name = wb.Name
->4. Serielle Textdatei neu anlegen
-> (gleicher Pfad, Dateiname, Endung txt)
my_newname = Left(my_name, Len(my_name) - Len(.cvs)) & .txt
->4.1 Prüfen, ob file bereits existiert
my_file = Dir(my_path & Application.PathSeparator & my_newname)
If my_file <> Then
->4.1.1 wenn ja, fragen auf Überschreiben
ret = MsgBox( _
Das Textfile & vbLf & _
my_path & Application.PathSeparator & my_newname & vbLf & _
existiert bereits! & vbLf & vbLf & _
Soll die datei überschrieben werden?, _
vbQuestion + vbYesNo + vbDefaultButton2)
->4.1.1.1 nein -> Abbruch
If ret <> vbYes Then
GoTo Aufraeumen
Else
Kill my_path & Application.PathSeparator & my_newname
End If
End If
Open my_path & Application.PathSeparator & my_newname For Output As #1
->5. Zellinhalt des beschriebenen Bereichs zeilenweise
-> in Textdatei schreiben, abschliessen mit Linefeed
For z = l_row_first To l_row_last
For s = l_col_first To l_col_last
Print #1, ws.Cells(z, s).Value
Next
Next
->6. Textdatei schliessen
Close #1
->7. Vollzug melden
MsgBox ( _
my_path & Application.PathSeparator & my_name & vbLf & _
wurde seriell in der Textdatei & vbLf & _
my_path & Application.PathSeparator & my_newname & vbLf & _
gespeichert.)
->8. Aufräumen
Aufraeumen:
Set ws = Nothing: Set wb = Nothing
End Sub
Function CSV_Matrix_bestimmen(ws As Worksheet, _
l_za As Long, l_ze As Long, _
l_spa As Long, l_spe As Long) As Boolean
Dim l_max_row As Long, l_max_col As Long, x As Long
Dim l_cols As Long, l_anz As Long
->liefert die erste/letzte beschriebene Spalte/Zeile
->des Arbeitsblattes
->gibt FALSE zurück, wenn das Arbeitsblatt keinen Inhalt hat
CSV_Matrix_bestimmen = True
->letzte Spalte bestimmen
l_spe = ws.Cells.SpecialCells(xlCellTypeLastCell).Column
If l_spe = 0 Then
CSV_Matrix_bestimmen = False: Exit Function
End If
For x = l_spe To 1 Step -1
If (1 < ws.Cells(ws.Rows.Count, x).End(xlUp).Row) Or _
(ws.Cells(1, x).Value <> ) Then
l_spe = x: Exit For
End If
l_spe = x
Next
->letzte Zeile bestimmen
l_ze = ws.Cells.SpecialCells(xlCellTypeLastCell).Row
If l_ze = 0 Then
CSV_Matrix_bestimmen = False: Exit Function
End If
For x = l_ze To 1 Step -1
If (1 < ws.Cells(x, ws.Columns.Count).End(xlToLeft).Column) Or _
(ws.Cells(x, 1).Value <> ) Then
l_ze = x: Exit For
End If
l_ze = x
Next
->Spalte=1, Zeile=1 und leere Zelle -> Blatt leer
If l_ze = 1 And l_spe = 1 And ws.Cells(1, 1).Value = Then
CSV_Matrix_bestimmen = False: Exit Function
End If
->erste Spalte bestimmen
l_spa = 1
For x = 1 To l_spe
If (1 < ws.Cells(ws.Rows.Count, x).End(xlUp).Row) Or _
(ws.Cells(1, x).Value <> ) Then
l_spa = x: Exit For
End If
l_spa = x
Next
->erste Zeile bestimmen
l_za = 1
For x = 1 To l_ze
If (1 < ws.Cells(x, ws.Columns.Count).End(xlToLeft).Column) Or _
(ws.Cells(x, 1).Value <> ) Then
l_za = x: Exit For
End If
l_za = x
Next
End Function
