Option Explicit
Sub AutoRange_Export()
Dim ws As Worksheet
Dim wb As Workbook
Dim WorkRng As Range
Dim CSVName As String
Dim strErr As String
Dim lngDauer As Variant
Dim AzBuecher&
Dim NameAnhang As String
CSVName = "CSV-Transfer"
lngDauer = 3
Set WorkRng = ActiveCell
Call auto_range(strErr, WorkRng, AzBuecher, NameAnhang)
If strErr <> "" Then GoTo Fehler
Set wb = Workbooks.Add
wb.Worksheets(1).Name = WorkRng.Worksheet.Name
WorkRng.Copy Destination:=wb.Worksheets(1).Range("A1")
Application.DisplayAlerts = False
On Error GoTo Fehler
wb.SaveAs Filename:=ThisWorkbook.Path & "\" & CSVName & NameAnhang, _
FileFormat:=xlCSV, _
CreateBackup:=False, _
Local:=True
wb.Close True
Application.DisplayAlerts = True
Call MessageBox_zeitgesteuert(CSVName, NameAnhang, lngDauer, AzBuecher)
Exit Sub
Fehler:
If strErr = "" Then strErr = "Fehler beim Speichern"
MsgBox "Keine Datei erstellt." & vbLf & strErr, vbCritical, "ein Fehler ist aufgetreten"
End Sub
Sub auto_range(sErr As String, WorkRng As Range, lngAzB As Long, NameAnhang As String)
Dim i&, LastRow&, FirstRow&
Dim VorlFeldnamen As Variant
VorlFeldnamen = Application.Transpose( _
Application.Transpose(Range(Range("Kopfz_S"), Range("Kopfz_6").End(xlToLeft))))
sErr = ""
If WorkRng <> VorlFeldnamen(1) Then
sErr = " Bitte den ersten Feldnamen " & Range("Kopfz_S").Value & " wählen! "
Exit Sub
End If
For i = LBound(VorlFeldnamen) To UBound(VorlFeldnamen)
If WorkRng.Offset(, -1 + i).Value <> VorlFeldnamen(i) Or WorkRng.Offset(, -1 + i).Value = "" Then
Exit For
End If
Next
If i <= UBound(VorlFeldnamen) Then
sErr = "Feldnamen stimmen nicht überein - Siehe Blatt Anleitung!!"
Exit Sub
End If
lngAzB = WorkRng.End(xlDown).Row - WorkRng.Row
If lngAzB > Range("MaxBuecher").Value Then
sErr = lngAzB & " Bücher sind zu viel." & vbLf & _
"Es sind nur " & Range("MaxBuecher").Value & " im Fach vorgesehen"
Else
NameAnhang = IIf(Range("okExtension").Value >= 1, "_ab_" + WorkRng.Offset(1, 0).Value, "")
NameAnhang = NameAnhang & "_bis_" + WorkRng.Offset(lngAzB)
Set WorkRng = WorkRng.Resize(lngAzB + 1, UBound(VorlFeldnamen))
End If
End Sub
Private Sub MessageBox_zeitgesteuert(CSVName, NameAnhang, lngDauer, AzBuecher)
Dim iAnzeige As Integer
Dim objShell As Object
Set objShell = CreateObject("WScript.Shell")
iAnzeige = objShell.Popup("In der neuen Datei " & CSVName & NameAnhang & ".CSV wurden " & _
AzBuecher & " Bücher gespeichert", _
lngDauer, _
"CSV für BOOKcook Import Anzeigedauer: " & lngDauer & " sec.", _
vbInformation)
End Sub