Option Explicit
Sub AutoRange_Export()
gestartet werden. Der nach der Vorlage (siehe Blatt ANLEITUNG) _
erkannte Zellbereich wird als Bereich erkannt und in eine _
Semikolongetrennte *.CSV-Datei gespeichert
Dim WorkRng As Variant
Dim Worksheetx As Variant
Dim CSVName As String
Dim lngDauer As Variant
Dim AzBuecher As Variant
Dim ErsteZelleValue As String
Dim ErrorFlag As Boolean
CSVName = "CSV-Transfer"
lngDauer = 1.5
On Error Resume Next
Set WorkRng = Application.Selection
WorkRng.Select
Range(WorkRng).Select
Worksheetx = ActiveSheet.Name
Call auto_range(Worksheetx, ErsteZelleValue, ErrorFlag, WorkRng, AzBuecher)
If ErrorFlag = True Then GoTo Fehler
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, AzBuecher)
Fehler:
End Sub
Sub auto_range(Worksheetx, ErsteZelleValue, ErrorFlag, WorkRng, AzBuecher)
Dim numCol As Variant
Dim cntcol As Variant
Dim LastCol As Variant
Dim LastRow As Variant
Dim Startzelle As Variant
Dim Endzeile As Variant
Dim Text As Variant
Dim MaxBuecher As Variant
Dim VorlFeldnamen(1 To 6) As Variant
Dim i As Integer
ErrorFlag = False
Sheets("ANLEITUNG").Select
Range("Kopfz_S").Select
For i = 1 To 6
VorlFeldnamen(i) = Selection.Value
ActiveCell.Offset(0, 1).Select
Next i
Range("MaxBuecher").Select
MaxBuecher = Selection.Value
Sheets(Worksheetx).Select
If ActiveCell.Value = VorlFeldnamen(1) Then
Startzelle = ActiveCell.Address
Else
ErrorFlag = True
GoTo FehlerZeileErsterFeldname
End If
ActiveCell.Offset(0, 1).Select
For i = 2 To 6
If ActiveCell.Value <> VorlFeldnamen(i) Or VorlFeldnamen(i) = "" Then
GoTo VorlagenEnde
ElseIf ActiveCell.Value = "" Then
MsgBox "Feldnamen stimmen nicht überein - Siehe Blatt Anleitung!!", vbCritical
ErrorFlag = True
GoTo Brexit
End If
ActiveCell.Offset(0, 1).Select
Next i
VorlagenEnde:
LastCol = i - 1
ActiveCell.Offset(0, -1).Select
MaxBuecher erreicht
Range(Startzelle).Select
numCol = ActiveCell.Address
cntcol = "1"
Text = ActiveCell.Value
ActiveCell.Offset(1, 0).Select
Do
ActiveCell.Offset(1, 0).Select
cntcol = cntcol + 1
Loop While ActiveCell.Value <> ""
ActiveCell.Offset(-1, 0).Select
LastRow = cntcol
Endzeile = ActiveCell.Address
If LastRow > MaxBuecher + 1 Then
MsgBox cntcol - 1 & " Bücher, es sind nur " & MaxBuecher & " im Fach vorgesehen", vbExclamation
End If
AzBuecher = "777"
Datenzellen_geprüft:
Range(Startzelle).Resize(LastRow, LastCol).Select
Set WorkRng = Application.Selection
GoTo Brexit
FehlerZeile:
MsgBox ("Zellauswahl ungültig"), vbCritical
ErrorFlag = True
GoTo Brexit
FehlerZeileErsterFeldname:
MsgBox ("Bitte ersten Feldnamen Wählen (Standort)"), vbCritical
ErrorFlag = True
GoTo Brexit
FehlerSpalte:
MsgBox ("Zellauswahl ungültig, da Leerzelle in 1.Spalte oder eine weitere Kopfzelle ") & _
("in der 1. Spalte"), vbCritical
ErrorFlag = True
Brexit:
Sheets(Worksheetx).Select
End Sub
Sub MessageBox_zeitgesteuert(CSVName, lngDauer, AzBuecher)
Dim iAnzeige As Integer
Dim objShell As Object
Set objShell = CreateObject("WScript.Shell")
iAnzeige = objShell.Popup("In der neuen Datei " & CSVName & ".CSV wurden " & AzBuecher & " Bücher gespeichert", _
lngDauer, "CSV für BOOKcook Import Anzeigedauer: " & lngDauer _
& " sec.", vbInformation)
End Sub