Grundsatzfrage Add-In

Sub CSVExport() Dim sFile As Variant, msgAntwort As Variant Dim Daten As Range, Zeile As Object, Zelle As Object Dim strTemp As String 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 Exit Sub 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 End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Russi
Vielen Dank. Es hat alles perfekt funktioniert.
Nachstehend noch den vollständigen Code fürs Archiv.
Gruss
Chris


Private Sub Workbook_Open()
Dim cbmCommandBarMenu As CommandBar
Dim cbmDemoMenu As CommandBarPopup
Dim cbmCommandBarMenuCascade As CommandBarPopup
' Clear the way for new menu.
On Error Resume Next
Application.CommandBars("Worksheet Menu Bar") _
.Controls("&Location Management").Delete
' Identify built-in menu bar to work with.
Set cbmCommandBarMenu = Application _
.CommandBars("Worksheet Menu Bar")
' Add the new menu.
With cbmCommandBarMenu.Controls
Set cbmDemoMenu = _
.Add(Type:=msoControlPopup)
' Set caption for new menu.
With cbmDemoMenu
.Caption = "&Location Management"
.Visible = True
' Add single menu item and set properties.
With .Controls.Add(msoControlButton)
.OnAction = "CSVExport"
.Caption = "&CSV Export"
.Visible = True
End With
End With
End With
End Sub

Option Explicit
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

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread