|
Hallo, mein Problem ist das mein Makro bzw. die Excel Datei an sich abstürzt wenn ich das Makro per Button ausführe.
Starte ich es aber über den VBA Editor läuft alles reibungslos. Ich bin dahingehend jetzt etwas ratlos.
im folgenden der Code, falls es an diesem liegen sollte:
'Prüft, ob alle Variablen deklariert werden, wenn nicht wird ein Fehler zur Laufzeit erzeugt
Option Explicit
Dim Zeile As Integer 'Zeile aus der die Daten kopiert werden
Dim ZielZeile As Integer 'Zeile in der die Daten eingefügt werden
Dim Monat As String 'Bestimmt den Syntax des Monats, Bsp. 01.01.2000
Dim q_datei As String 'Setzt den Pfad aus der die Datei kopiert werden soll
'Mit dieser Funktion werden die Daten aus dem Wunschordner kopiert
'Es wird geprüft ob die Daten des letzten Monats, und danach die Daten des aktuellen Monats bereits eingeflegt wurden
Sub Daten_holen()
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
prüfe_ob_vorhanden_letzter_monat
End Sub
Function prüfe_ob_vorhanden_letzter_monat() As Boolean
Dim I As Integer
I = 1
Dim boolsch As Boolean
'Prüft genau die Anzahl der Sheets
Do While I <= Worksheets.Count
'Wenn ein Sheet mit dem ersten Tag des aktuellen Monats existiert dann setze boolsch auf 'Wahr'
If Worksheets(I).Name = ersterTag_letztesMonat Then
prüfe_ob_vorhanden_letzter_monat = True
End If
I = I + 1
Loop
Dim statement
If prüfe_ob_vorhanden_letzter_monat = False Then
statement = MsgBox("Die Daten vom " & ersterTag_letztesMonat & " wurden noch nicht eingepflegt. " & _
"Sollen die Daten nun eingefügt werden?", vbQuestion + vbYesNoCancel)
Select Case statement
Case vbYes
MsgBox_popup ("Die Daten werden jetzt eingepflegt")
'Funktionsaufrufe
ThisWorkbook.Worksheets.Add after:=Sheets(1)
ActiveSheet.Name = ersterTag_letztesMonat
'Funktionsaufruf
daten_kopieren_letzter_Monat
Case vbNo
MsgBox_popup ("Die Daten werden nicht eingepflegt")
Case vbCancel
MsgBox_popup ("Das Programm wird abgebrochen")
With Application
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End
End Select
Else
MsgBox "Die Daten vom " & ersterTag_letztesMonat & " wurden bereits eingepflegt", vbInformation
End If
'Ruft jetzt die Funktion "prüfe-ob_vorhanden_aktueller_monat" auf
prüfe_ob_vorhanden_aktueller_monat
End Function
Function prüfe_ob_vorhanden_aktueller_monat() As Boolean
Dim I As Integer
I = 1
'Prüft genau die Anzahl der Sheets
Do While I <= Worksheets.Count
'Wenn ein Sheet mit dem ersten Tag des aktuellen Monats existiert dann setze boolsch auf 'Wahr'
If Worksheets(I).Name = ersterTag_aktuellesMonat Then
prüfe_ob_vorhanden_aktueller_monat = True
End If
I = I + 1
Loop
Dim statement
If prüfe_ob_vorhanden_aktueller_monat = True Then
MsgBox "Die Daten vom " & ersterTag_aktuellesMonat & " wurden bereits eingepflegt", vbInformation
Else
statement = MsgBox("Die Daten vom " & ersterTag_aktuellesMonat & " wurden noch nicht eingepflegt. " & _
"Sollen die Daten nun eingefügt werden?", vbQuestion + vbYesNoCancel)
Select Case statement
Case vbYes
MsgBox_popup ("Die Daten werden jetzt eingepflegt")
'Funktionsaufrufe
ThisWorkbook.Worksheets.Add after:=Sheets(1)
ActiveSheet.Name = ersterTag_aktuellesMonat
'Funktionsaufruf
daten_kopieren_aktueller_Monat
Case vbNo
MsgBox_popup ("Die Daten werden nicht eingepflegt")
With Application
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Case vbCancel
MsgBox_popup ("Das Programm wird abgebrochen")
With Application
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End
End Select
End If
End Function
Sub daten_kopieren_letzter_Monat()
Monat = ersterTag_letztesMonat
q_datei = Monat & "_Mitarbeiterübersicht.xlsx"
'Öffnet die Excel-Quell-Datei
Mitarbeiterübersicht_letztes_monat_öffnen
'Kopf der Quelldatei kopieren
Workbooks(q_datei).Worksheets("CO01").Range("A1:L2").Copy
Workbooks("Krankenstand.xlsm").Worksheets(Monat).Range("A1:L2").PasteSpecial Paste:=xlPasteAll
Workbooks("Krankenstand.xlsm").Worksheets(Monat).Range("A1:L2").PasteSpecial Paste:=8
'Durchläuft die Excel-Datei von unten nach oben bis zur letzten belegten Zeile
For Zeile = Range("E" & Rows.Count).End(xlUp).Row To 2 Step -1
Workbooks(q_datei).Activate
'Selektionskriterium Kostenstelle
If Range("E" & Zeile) = 1605 Or Range("E" & Zeile) = 1830 Then
Workbooks(q_datei).Worksheets("CO01").Range("A" & Zeile & ":L" & Zeile).Copy
'Sucht die erste leere Zeile des Blattes "Mitarbeiter" anhand der Spalte "A"
ZielZeile = Workbooks("Krankenstand.xlsm").Worksheets(Monat).Cells(Rows.Count, 1).End(xlUp).Row + 1
'Fügt die selektierten Werte in die //!!Name!!// Datei ein
Workbooks("Krankenstand.xlsm").Worksheets(Monat).Range("A" & ZielZeile).PasteSpecial Paste:=xlAll
End If
Next
'Quelldatei wieder schließen
Workbooks(q_datei).Close SaveChanges:=False
MsgBox "Die Daten vom " & Monat & " wurden eingefügt!"
End Sub
Sub daten_kopieren_aktueller_Monat()
Monat = ersterTag_aktuellesMonat
q_datei = Monat & "_Mitarbeiterübersicht.xlsx"
'Öffnet die Excel-Quell-Datei
Mitarbeiterübersicht_diesen_monat_öffnen
'Kopf der Quelldatei kopieren
Workbooks(q_datei).Worksheets("CO01").Range("A1:L2").Copy
Workbooks("Krankenstand.xlsm").Worksheets(Monat).Range("A1:L2").PasteSpecial Paste:=xlPasteAll
Workbooks("Krankenstand.xlsm").Worksheets(Monat).Range("A1:L2").PasteSpecial Paste:=8
'Durchläuft die Excel-Datei von unten nach oben bis zur letzten belegten Zeile
For Zeile = Range("E" & Rows.Count).End(xlUp).Row To 2 Step -1
Workbooks(q_datei).Activate
'Selektionskriterium Kostenstelle
If Range("E" & Zeile) = 1605 Or Range("E" & Zeile) = 1830 Then
Workbooks(q_datei).Worksheets("CO01").Range("A" & Zeile & ":L" & Zeile).Copy
'Sucht die erste leere Zeile des Blattes "Mitarbeiter" anhand der Spalte "A"
ZielZeile = Workbooks("Krankenstand.xlsm").Worksheets(Monat).Cells(Rows.Count, 1).End(xlUp).Row + 1
'Fügt die selektierten Werte in die //!!Name!!// Datei ein
Workbooks("Krankenstand.xlsm").Worksheets(Monat).Range("A" & ZielZeile).PasteSpecial Paste:=xlAll
End If
Next
'Quelldatei wieder schließen
Workbooks(q_datei).Close SaveChanges:=False
MsgBox "Die Daten vom " & Monat & " wurden eingefügt!"
With Application
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Function Mitarbeiterübersicht_letztes_monat_öffnen()
Dim datum As Date
Dim Pfad As String
Dim quelldatei As String
'Ruft die Funktion 'ersterTag_letztesMonat' auf
datum = ersterTag_letztesMonat
Pfad = "C:\Users\_name_\Mitarbeiterübersicht\Mitarbeiterübersicht\Originale\"
'Die Quelldatei entspricht der Datei mit dem neuesten Datum
quelldatei = Pfad & datum & "_Mitarbeiterübersicht.xlsx"
Workbooks.Open quelldatei
End Function
Function Mitarbeiterübersicht_diesen_monat_öffnen()
Dim datum As Date
Dim Pfad As String
Dim quelldatei As String
'Ruft die Funktion 'ersterTag_letztesMonat' auf
datum = ersterTag_aktuellesMonat
Pfad = "C:\Users\_name_\Desktop\Mitarbeiterübersicht\Mitarbeiterübersicht\Originale\"
'Die Quelldatei entspricht der Datei mit dem neuesten Datum
quelldatei = Pfad & datum & "_Mitarbeiterübersicht.xlsx"
Workbooks.Open quelldatei
End Function
Function ersterTag_letztesMonat() As String
Dim LastDay As Date
LastDay = DateSerial(Year(Date), Month(Date), 0)
ersterTag_letztesMonat = LastDay - Day(LastDay) + 1
End Function
Function ersterTag_aktuellesMonat() As Date
ersterTag_aktuellesMonat = DateSerial(Year(Date), Month(Date), 1)
End Function
Public Function MsgBox_popup(text As String)
Dim objWSH As Object
Set objWSH = CreateObject("WScript.Shell")
objWSH.popup text, 1
Set objWSH = Nothing
End Function
Sub hinten_anfuegen()
Dim anzahl_sheets As Integer
anzahl_sheets = Sheets.Count 'Anzahl der vorhanden Blätter
This.Add after:=Sheets(anzahl_sheets) 'Sheet hizufügen
End Sub
|