Option Explicit
Sub RangetoCSV_Export()
Dim Rng As Range
Dim WorkRng As Range
Dim xFile As Variant
Dim zelle As Variant
Dim ZelleAnfang As Variant
Dim ZelleEnde As Variant
Dim CSVName As String
Dim lngDauer As Long
Dim ErsteZelleValue As String
ErsteZelleValue = "Standort"
CSVName = "CSV-Transfer"
lngDauer = 2
On Error Resume Next
Set WorkRng = Application.Selection
Range(WorkRng).Select
If ActiveCell.Value <> ErsteZelleValue Then
MsgBox "!! Die erste Zelle muss """ & ErsteZelleValue & """ sein !!", vbCritical
GoTo Fehler
End If
Application.ActiveSheet.Copy
Application.ActiveSheet.Cells.Clear
WorkRng.Copy Application.ActiveSheet.Range("A1")
Application.DisplayAlerts = False
Application.ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & CSVName, FileFormat:=xlCSV, _
CreateBackup:=False, Local:=True
Application.DisplayAlerts = True
Application.ActiveWorkbook.Close True
Call MessageBox_zeitgesteuert(CSVName, lngDauer)
Fehler:
End Sub
Sub MessageBox_zeitgesteuert(CSVName, lngDauer)
Dim iAnzeige As Integer
Dim objShell As Object
Set objShell = CreateObject("WScript.Shell")
iAnzeige = objShell.Popup("Die neue Datei " & CSVName & ".CSV wurde gespeichert", _
lngDauer, "CSV für BOOKcook Import Anzeige: " & lngDauer & " sec.", vbInformation)
End Sub