Sub CSVExport()
Dim sFile As Variant, msgAntwort As Variant
Dim Daten As Range, Zeile As Object, Zelle As Object
Dim strTemp As String
On Error GoTo errorhandler
With ActiveSheet
sFile = Application.GetSaveAsFilename(InitialFilename:="Location Management " & .Range("A2") & ".csv", _
FileFilter:="CSV-Datei (*.csv), *.csv")
If sFile = False Then Exit Sub
If Dir(sFile) <> "" Then
msgAntwort = MsgBox("Die Datei '" & sFile & "' besteht bereits. Möchten Sie die bestehende Datei ersetzen?", _
vbQuestion + vbYesNo, "Warnung")
If msgAntwort = vbNo Then Exit Sub
End If
Set Daten = .UsedRange
Close
Open sFile For Output As #1
For Each Zeile In Daten.Rows
If Zeile.Row > .Range("A65536").End(xlUp).Row Then
MsgBox "Die Datei wurde erfolgreich exportiert.", vbInformation, "Export erfolgreich"
Exit Sub
End If
For Each Zelle In Zeile.Cells
If (Zelle.Column = 4 Or Zelle.Column = 5) And Zelle <> "" Then
strTemp = strTemp & CStr(Format(Zelle, "DD") & "/" & Format(Zelle, "MM") _
& "/" & Format(Zelle, "YY")) & ";"
Else
If Zelle.Column >= 22 And Zelle.Column <= 38 And Zelle <> "" Then
strTemp = strTemp & CStr(Format(Zelle, "0")) & ";"
Else
strTemp = strTemp & CStr(Zelle.Text) & ";"
End If
End If
Next Zelle
Print #1, strTemp
strTemp = ""
Next Zeile
Close #1
End With
MsgBox "Die Datei wurde erfolgreich exportiert.", vbInformation, "Export erfolgreich"
Exit Sub
errorhandler:
MsgBox "Es ist ein Fehler aufgetreten. Die Datei konnte nicht vollständig exportiert werden.", vbCritical, "Fehlermeldung"
End Sub
Sub TXTExport()
Dim sFile As Variant, msgAntwort As Variant
Dim Daten As Range, Zeile As Object, Zelle As Object
Dim strTemp As String
On Error GoTo errorhandler
With ActiveSheet
sFile = Application.GetSaveAsFilename(InitialFilename:="DeineVorgabe" & ".txt", _
FileFilter:="TXT-Datei (*.txt), *.txt")
If sFile = False Then Exit Sub
If Dir(sFile) <> "" Then
msgAntwort = MsgBox("Die Datei '" & sFile & "' besteht bereits. Möchten Sie die bestehende Datei ersetzen?", _
vbQuestion + vbYesNo, "Warnung")
If msgAntwort = vbNo Then Exit Sub
End If
Set Daten = .UsedRange
Close
Open sFile For Output As #1
For Each Zeile In Daten.Rows
For Each Zelle In Zeile.Cells
If Zelle.Column = 1 Then
strTemp = Zelle
Else
strTemp = strTemp & vbTab & Zelle
End If
Next Zelle
Print #1, strTemp
strTemp = ""
Next Zeile
Close #1
End With
MsgBox "Die Datei wurde erfolgreich exportiert.", vbInformation, "Export erfolgreich"
Exit Sub
errorhandler:
MsgBox "Es ist ein Fehler aufgetreten. Die Datei konnte nicht vollständig exportiert werden.", vbCritical, "Fehlermeldung"
End Sub
Die Datei https://www.herber.de/bbs/user/9534.xls wurde aus Datenschutzgründen gelöscht
ich hoffe dass sie dir weiterhelfen
Sub Text_Datei_erstellen()
Dim Zahl As Integer, Number As Integer
Dim Counter As Byte
Dim Unterschied As Double
Dim WS1 As Worksheet, WS2 As Worksheet, WS3 As Worksheet
Dim sFile As Variant, msgAntwort As Variant
Dim Daten As Range, Zeile As Object, Zelle As Object
Dim strTemp As String
On Error GoTo ErrorHandler
' Plausibilitätsprüfung
Set WS1 = Worksheets("Tabelle1")
If IsEmpty(WS1.Range("J4")) Then
MsgBox ("Das Feld J4 darf nicht Leer sein")
Exit Sub
End If
If IsEmpty(WS1.Range("J6")) Then
MsgBox ("Das Feld J6 darf nicht Leer sein")
Exit Sub
End If
Application.ScreenUpdating = False
' Blätter löschen, sofern vorhanden
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("ASCI").Delete
Worksheets("Export").Delete
Application.DisplayAlerts = True
' Neue Blätter erstellen und benennen
On Error GoTo ErrorHandler
Set WS2 = Sheets.Add
Set WS3 = Sheets.Add
WS2.Name = "ASCI"
WS3.Name = "Export"
WS2.Range("A1") = Mid(WS1.Range("J4"), 5, 3)
WS2.Range("B1") = Mid(WS1.Range("J4"), 15, 2)
WS2.Range("C1") = Mid(WS1.Range("J6"), 2, 5)
WS2.Range("D1") = Mid(WS1.Range("J6"), 11, 5)
WS3.Range("H1").FormulaR1C1 = "=ASCI!RC[-7]&ASCI!RC[-6]&ASCI!RC[-5]&ASCI!RC[-4]&ASCI!RC[-3]&ASCI!RC[-2]&ASCI!RC[-1]"
Zahl = 11
Number = 2
Counter = 0
Unterschied = 9
Do While Counter < 15
If IsEmpty(WS1.Range("K" & Zahl)) Then
Counter = Counter + 1
Zahl = Zahl + 1
Unterschied = Unterschied + 1
Else
If IsNumeric(WS1.Range("B" & Zahl)) Then
WS2.Range("A" & Number).FormulaR1C1 = "=Tabelle1!R[+" & Unterschied & "]C[+14] & REPT("" "",2-LEN(Tabelle1!R[" & Unterschied & "]C[+14]))"
WS2.Range("B" & Number).FormulaR1C1 = "=Tabelle1!R[+" & Unterschied & "]C[+9] & REPT("" "",32-LEN(Tabelle1!R[+" & Unterschied & "]C[+9]))"
WS2.Range("C" & Number).FormulaR1C1 = "=Tabelle1!R[+" & Unterschied & "]C & REPT("" "",60-LEN(Tabelle1!R[+" & Unterschied & "]C))"
WS2.Range("D" & Number).FormulaR1C1 = "=Tabelle1!R[+" & Unterschied & "]C[+4] & REPT("" "",10-LEN(Tabelle1!R[+" & Unterschied & "]C[+4]))"
WS2.Range("E" & Number).FormulaR1C1 = "=Tabelle1!R[+" & Unterschied & "]C[+4] & REPT("" "",10-LEN(Tabelle1!R[+" & Unterschied & "]C[+4]))"
WS2.Range("F" & Number).FormulaR1C1 = "=Tabelle1!R[+" & Unterschied & "]C[+10] & REPT("" "",20-LEN(Tabelle1!R[+" & Unterschied & "]C[+10]))"
WS2.Range("G" & Number).FormulaR1C1 = "=Tabelle1!R[+" & Unterschied & "]C[+10] & REPT("" "",60-LEN(Tabelle1!R[+" & Unterschied & "]C[+10]))"
WS3.Range("H" & Number).FormulaR1C1 = "=ASCI!RC[-6]&ASCI!RC[-5]&ASCI!RC[-4]&ASCI!RC[-3]&ASCI!RC[-2]&ASCI!RC[-1]"
Counter = 0
Zahl = Zahl + 1
Number = Number + 1
Else
Unterschied = Unterschied + 1
Zahl = Zahl + 1
End If
End If
Loop
With WS3
sFile = Application.GetSaveAsFilename(InitialFilename:="" & WS3.Range("H1") & "_" & Date$ & ".txt", _
FileFilter:="TXT-Datei (*.txt), *.txt")
If sFile = False Then Exit Sub
If Dir(sFile) <> "" Then
msgAntwort = MsgBox("Die Datei '" & sFile & "' besteht bereits. Möchten Sie die bestehende Datei ersetzen?", _
vbQuestion + vbYesNo, "Warnung")
If msgAntwort = vbNo Then Exit Sub
End If
.Columns("A:G").Delete Shift:=xlToLeft
Set Daten = .UsedRange
Close
Open sFile For Output As #1
For Each Zeile In Daten.Rows
For Each Zelle In Zeile.Cells
If Zelle.Column = 1 Then
strTemp = Zelle
Else
strTemp = strTemp & vbTab & Zelle
End If
Next Zelle
Print #1, strTemp
strTemp = ""
Next Zeile
Close #1
End With
Application.ScreenUpdating = True
MsgBox "Die Datei wurde erfolgreich exportiert.", vbInformation, "Export erfolgreich"
Exit Sub
ErrorHandler:
MsgBox "Es ist ein Fehler aufgetreten. Die Datei konnte nicht vollständig exportiert werden.", vbCritical, "Fehlermeldung"
End Sub