Office: (Office 2010) Mit Makro kontrollieren ob bestimmte Werte vorhanden sind

okrim · 11. März 2018

Hallo Aloys,

vielen Dank, werde es nach Feierabend gleich ausprobieren *Smilie

Gruß Mirko

okrim · 12. März 2018

Hallo Aloys,

hab es gerade ausprobiert, aber es geht leider nicht, es trägt mir kein einzigen Termin zum Rodelabend ein???

Gruß Mirko

aloys78 · 12. März 2018

Hallo Mirko,

kannst Du mal den getesteten Code zur Verfügung stellen und kurz erläutern, was Du genau testen wolltest.

Ich denke, ich kann mir es heute abend noch anschauen.

Gruß
Aloys

okrim · 12. März 2018

Hallo Aloys,

ich wollte das Jahr wechseln, dabei sollte es die Fehleranzeige in den Monatsblättern auch in Grundsellung bringen, das heisst es sollten die neuen Rodelabendtermine aus der Zwischenablage in die Fehleranzeige eingetragen werden.

Hier der Code für das Löschen

Code:

Private Sub Button_Fertig_Click()

Dim nT As Long ' Anzahl Tage im Monat zum Diensplaneinträge löschen
Dim c As Long, c1 As Long, c2 As Long ' Spalten# zum Diensplaneinträge löschen
Dim i As Integer

'Schaut ob checkBox aktiv ist und Speichert die Datei neu an
If Form_jahreswechsel.Controls("CheckBox1").Value = True Then

ActiveWorkbook.SaveAs (akt_pfad & "/" & neue_datei) 'Speichert die Datei
MsgBox "Der Diensplan " & Sheets("Einstellungen").Range("D4") & " wurde unter " & akt_pfad & "/" & neue_datei & " gespeichert!" _
, vbInformation, "Ehrwalder Almbahn"

'Löscht sämtliche Diensplan Einträge inkl. Namen ausser die Namen unter Mitarbeiter

' Schaltet das Diplay Update aus, man sieht nicht was Excel macht bis es wieder angeschaltet wird
Application.ScreenUpdating = False

' Diensplan Einträge löschen für Winter
For i = 1 To 5
nT = Day(DateSerial(Year(Worksheets(i).Range("C3")), Month(Worksheets(i).Range("C3")) + 1, 0)) ' Anzahl Tage im aktuellen Monat
c1 = 3 ' Spalte C = Start-Spalte
c2 = c1 + nT - 1 ' letzte Spalte Monatsbereich
With Worksheets(i).Range(Worksheets(i).Cells(6, "C"), Worksheets(i).Cells(58, c2)) ' maximaler Monatsbereich
Application.EnableEvents = False
Worksheets(i).Range(Worksheets(i).Cells(6, "C"), Worksheets(i).Cells(58, c2)).ClearContents
Application.EnableEvents = True
Worksheets(i).Range("A6:A58").ClearContents
End With
Next i

' Diensplan Einträge löschen für Sommer
For i = 6 To 12
nT = Day(DateSerial(Year(Worksheets(i).Range("C3")), Month(Worksheets(i).Range("C3")) + 1, 0)) ' Anzahl Tage im aktuellen Monat
c1 = 3 ' Spalte C = Start-Spalte
c2 = c1 + nT - 1 ' letzte Spalte Monatsbereich
With Worksheets(i).Range(Worksheets(i).Cells(6, "C"), Worksheets(i).Cells(58, c2)) ' maximaler Monatsbereich
Application.EnableEvents = False
Worksheets(i).Range(Worksheets(i).Cells(6, "C"), Worksheets(i).Cells(58, c2)).ClearContents
Application.EnableEvents = True
Worksheets(i).Range("A6:A58").ClearContents
End With
Next i

'Selektirt in den Tabellen Winter die Zelle C6
For i = 1 To 5
Sheets(i).Select
Sheets(i).Range("C6").Select
Next i

'Selektirt in den Tabellen Sommer die Zelle B6
For i = 6 To 12
Sheets(i).Select
Sheets(i).Range("C6").Select
Next i

' Setzt die Fehleranzeige in Grundstellung in Dezember bis November
' Version V 7.4 vom 12.03.2017
Dim arrSheet As Variant
arrSheet = Array("Januar", "Februar", "März", "April", "Mai", "Juni", "Juli", _
"August", "September", "Oktober", "November", "Dezember")
Call Array_Aufbau
For i = LBound(arrSheet) To UBound(arrSheet)
On Error Resume Next
Worksheets(arrSheet(i)).Activate
If Err.Number 0 Then
MsgBox "Blatt " & Worksheets(arrSheet(i)) & " wurde nicht gefunden !", vbCritical
Else
On Error GoTo 0
Call Anzeigebereich_Löschen(ActiveSheet)
End If
Next i
On Error GoTo 0

'Springt in Tabellen Einstellungen
Sheets("Einstellungen").Select

' Schaltet das Diplay Update ein
Application.ScreenUpdating = True
Unload Me
End If
Unload Me
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

hier mdl_Array

Code:

Option Explicit

' Version 6.4 vom 04.03.2018

' Globale Variable
Public p_ZBer_F As String, p_ZBer_D As String ' Bereiche zur Aufbereitung der Fehlernachricht in der Userform

Public p_ArrA() As String ' Array Anlagen-Texte für die aktuelle Jahreszeit
Public p_ArrA_Som() As String, p_ArrA_Win() As String ' Array Anlagen-Texte Sommer- bzw Winterzeit

Public p_ArrD() As Variant ' Array Dienste je Anlage für die aktuelle Jahreszeit
Public p_ArrD_Som() As Variant, p_ArrD_Win() As Variant ' Array Dienste je Anlage Sommer- bzw Winterzeit

Public p_ArrDG() As Variant ' Array aller Dienste für die aktuelle Jahreszeit
Public p_ArrDG_Som() As Variant, p_ArrDG_Win() As Variant ' Array aller Dienste Sommer- bzw Winterzeit
Public p_ArrDA() As Variant ' Array relative Adresse zur zugehörigen Anlage für die aktuelle Jahreszeit
Public p_ArrDA_Som() As Variant, p_ArrDA_Win() As Variant ' Array relative Adresse zur zugehörigen Anlage für die aktuelle Jahreszeit

Public p_ArrDS() As Variant ' Sonstige Dienste

Public p_ArrRT() As Long ' Rodelbahn-Termine

Public p_swArr As Boolean ' Schalter, True = Arrays sind aufgebaut

Sub Array_Aufbau()
' Version 6.4 vom 04.03.2018
Dim LRow As Long ' letzte Zeile
Dim LCol As Long ' letzte Spalte
Dim nDS As Long ' Gesamtzahl aller Dienste Sommer
Dim nDW As Long ' Gesamtzahl aller Dienste Winter
Dim a As Long, a2 As Long, a3 As Long ' Indices Array
Dim r As Long ' Zeilen#
Dim c As Long, c2 As Long ' Spalten#
Const sZeile As Long = 4 ' Startzeile Tabelle
Dim n As Long ' Zähler
Dim erg As Variant ' Ergebnis Match
Dim sw As Boolean

' check, ob Arrays schon aufgebaut sind

If p_swArr = True Then Exit Sub ' Arrays sind schon aufgebaut

'******************************************************************************
' Aufbau der Arrays p_ArrD_Win und p_ArrA_Win Winterzeit
'******************************************************************************
With Worksheets("Admin")

' Aufbau Array der Anlagen-Texte Winterzeit
erg = Application.Match("#Fin#", .Range("C" & sZeile & ":C20"), 0)
If Not IsNumeric(erg) Then
MsgBox "Anlagenblock Winterzeit in Admin hat keine Ende-Zeile !", vbCritical
Exit Sub
End If
a = erg - 1 ' Anzahl Anlage-Zeilen
LRow = a + sZeile - 1 ' letzte Zeile Anlage-Block
ReDim p_ArrA_Win(1 To a, 1 To 1) ' Array Anlagen-Texte

' max. Anzahl Dienste ermitteln un Array Dienste dimensionieren
a2 = 0
For r = sZeile To LRow
LCol = .Cells(r, Columns.Count).End(xlToLeft).Column
If LCol > a2 Then a2 = LCol
Next r
a2 = a2 - 3 ' max. Anzahl Dienste
ReDim p_ArrD_Win(1 To a, 0 To a2) ' Array Dienste

' Aufbau der Arrays p_arrA und p_arrD
a = 0
nDW = 0
For r = sZeile To LRow

' Array p_arrA
a = a + 1
a2 = 0
p_ArrA_Win(a, 1) = .Range("C" & r) ' Anlagen-Text

' Array p_arrD
LCol = .Cells(r, Columns.Count).End(xlToLeft).Column ' Spalten# letzter Dienst der Zeile
p_ArrD_Win(a, 0) = LCol - 3 ' Anzahl Dienste
nDW = nDW + p_ArrD_Win(a, 0)
For c = 4 To LCol
a2 = a2 + 1
p_ArrD_Win(a, a2) = .Cells(r, c) ' Dienst
Next c
Next r

'******************************************************************************
' Aufbau der Arrays p_ArrDG und p_ArrDA Winterzeit
'******************************************************************************
a3 = 0
ReDim p_ArrDG_Win(1 To nDW, 1 To 1)
ReDim p_ArrDA_Win(1 To nDW, 1 To 1)
For a = 1 To UBound(p_ArrD_Win, 1)
For a2 = 1 To p_ArrD_Win(a, 0)
a3 = a3 + 1
p_ArrDG_Win(a3, 1) = p_ArrD_Win(a, a2) ' Dienst
p_ArrDA_Win(a3, 1) = a ' Index zugehörige Anlage
Next a2
Next a

'******************************************************************************
' Aufbau der Arrays p_ArrD_Som und p_ArrA_Som Sommerzeit
'******************************************************************************

' Aufbau Array der Anlagen-Texte Sommerzeit
erg = Application.Match("#Fin#", .Range("C24:C26"), 0)
If Not IsNumeric(erg) Then
MsgBox "Anlagenblock Sommerzeit in Admin hat keine Ende-Zeile !", vbCritical, "Ehrwalder Almbahn"
Exit Sub
End If
a = erg - 1 ' Anzahl Anlage-Zeilen
LRow = a + 24 - 1 ' letzte Zeile Anlage-Block
ReDim p_ArrA_Som(1 To a, 1 To 1) ' Array Anlagen-Texte

' max. Anzahl Dienste ermitteln un Array Dienste dimensionieren
a2 = 0
For r = 24 To LRow
LCol = .Cells(r, Columns.Count).End(xlToLeft).Column
If LCol > a2 Then a2 = LCol
Next r
a2 = a2 - 3 ' max. Anzahl Dienste
ReDim p_ArrD_Som(1 To a, 0 To a2) ' Array Dienste

' Aufbau der Arrays p_arrA_Som und p_arrD_Som
a = 0
nDS = 0
For r = 24 To LRow

' Array p_arrA_Som
a = a + 1
a2 = 0
p_ArrA_Som(a, 1) = .Range("C" & r) ' Anlagen-Text

' Array p_arrD_Som
LCol = .Cells(r, Columns.Count).End(xlToLeft).Column ' Spalten# letzter Dienst der Zeile
p_ArrD_Som(a, 0) = LCol - 3 ' Anzahl Dienste
nDS = nDS + p_ArrD_Som(a, 0)
For c = 4 To LCol
a2 = a2 + 1
p_ArrD_Som(a, a2) = .Cells(r, c) ' Dienst
Next c
Next r

'******************************************************************************
' Aufbau der Arrays p_ArrDG und p_ArrDA Sommerzeit
'******************************************************************************
a3 = 0
ReDim p_ArrDG_Som(1 To nDS, 1 To 1)
ReDim p_ArrDA_Som(1 To nDS, 1 To 1)
For a = 1 To UBound(p_ArrD_Som, 1)
For a2 = 1 To p_ArrD_Som(a, 0)
a3 = a3 + 1
p_ArrDG_Som(a3, 1) = p_ArrD_Som(a, a2) ' Dienst
p_ArrDA_Som(a3, 1) = a ' Index zugehörige Anlage
Next a2
Next a

'******************************************************************************
' Aufbau Array p_ArrDS (Sonstige Dienste)
'******************************************************************************
erg = Application.Match("#Fin#", .Range("A1:A20"), 0)
If Not IsNumeric(erg) Then
MsgBox "Sonstige Dienste in Admin hat keine Ende-Zeile !", vbCritical, "Ehrwalder Almbahn"
Exit Sub
End If
LRow = erg - 1 ' letzte Zeile Anlage-Block
ReDim p_ArrDS(1 To LRow - sZeile + 1, 1 To 1)
a = 0
For r = sZeile To LRow
a = a + 1
p_ArrDS(a, 1) = .Range("A" & r)
Next r
End With

'******************************************************************************
' Aufbau Array p_ArrRT (Rodelbahn-Termine)
'******************************************************************************
With Worksheets("Zwischenspeicher")
LCol = .Cells(6, Columns.Count).End(xlToLeft).Column ' Spalte letzter Monat
a = WorksheetFunction.CountA(.Range(.Cells(6, "C"), .Cells(6, LCol))) + 1
If a < 1 Or a > 12 Then
MsgBox "Zwischenspeicher Zeile 6: Anzahl Monate nicht 1 bis 12 ", vbCritical, "Ehrwalder Almbahn"
Exit Sub
End If

c2 = 3 + (a - 1) * 4
sw = False
a = 0
For c = 3 To c2 Step 4
LRow = .Cells(Rows.Count, c).End(xlUp).Row
n = WorksheetFunction.CountIf(.Range(.Cells(8, c + 1), .Cells(LRow, c + 1)), "Ja")
If n > 0 Then
If sw = True Then
ReDim Preserve p_ArrRT(1 To UBound(p_ArrRT) + n)
Else
ReDim p_ArrRT(1 To n)
sw = True
End If
For r = 8 To LRow
If .Cells(r, c + 1) = "Ja" Then
a = a + 1
p_ArrRT(a) = CLng(.Cells(r, c))
End If
Next r
End If
Next c
End With
p_swArr = True ' Arrays sind aufgebaut

'****************************************************************************************************
' nur Test (siehe VBE / Extras / Eigenschaften von VBA-Projekt / Argumente für bedingte Compilierung
'****************************************************************************************************
Anzeigen:
With Worksheets("Admin")
#If Test = 1 Then
.Range("C30:C41") = p_ArrA_Win
.Range("C44:C45") = p_ArrA_Som
.Range(.Cells(30, "L"), .Cells(41, 12 + UBound(p_ArrD_Win, 2))) = p_ArrD_Win
.Range(.Cells(44, "L"), .Cells(45, 12 + UBound(p_ArrD_Som, 2))) = p_ArrD_Som
.Range(.Cells(30, "R"), .Cells(30 + nDW - 1, "R")) = p_ArrDG_Win
.Range(.Cells(30, "S"), .Cells(30 + nDW - 1, "S")) = p_ArrDA_Win
.Range(.Cells(30, "T"), .Cells(30 + nDS - 1, "T")) = p_ArrDG_Som
.Range(.Cells(30, "U"), .Cells(30 + nDS - 1, "U")) = p_ArrDA_Som
.Range(.Cells(30, "W"), .Cells(30 + UBound(p_ArrDS) - 1, "W")) = p_ArrDS
For a = 1 To UBound(p_ArrRT)
.Range("Y" & 30 + a - 1) = p_ArrRT(a)
Next a
#End If
End With
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

hier mdl_Löschen

Code:

Option Explicit

'===========================================================================
' Button Diensplan Einträge löschen für Winter
'===========================================================================

Sub DiensplanEinträgeLöschenWinter()
' Version v 6.4 vom 04.03.2018

Dim nT As Long ' Anzahl Tage im Monat
Dim c As Long, c1 As Long, c2 As Long ' Spalten#
Dim Zeit1 As Single, Zeit2 As Single
With ActiveSheet
nT = Day(DateSerial(Year(.Range("C3")), Month(.Range("C3")) + 1, 0)) ' Anzahl Tage im aktuellen Monat
c1 = 3 ' Spalte C = Start-Spalte
c2 = c1 + nT - 1 ' letzte Spalte Monatsbereich

If MsgBox("Wollen Sie die Einträge im Dienstplan wirklich löschen?", vbQuestion + vbYesNo, "Ehrwalder Almbahn") = vbYes Then
Zeit1 = Timer
Application.EnableEvents = False
.Range(.Cells(6, "C"), .Cells(58, c2)).ClearContents
Application.EnableEvents = True
Zeit1 = Timer - Zeit1: Zeit2 = Timer
Call Anzeigebereich_Löschen(ActiveSheet)
ActiveSheet.Range("C6").Select
Zeit2 = Timer - Zeit2
End If
End With
' MsgBox "Dauer Löschvorgang: " & Format(Zeit1, "0.00") & " plus " & Format(Zeit2, "0.00")
End Sub

'===========================================================================
' Button Diensplan Einträge löschen für Sommer
'===========================================================================

Sub DiensplanEinträgeLöschenSommer()
' Version v 6.4 vom 04.03.2018

Dim nT As Long ' Anzahl Tage im Monat
Dim c As Long, c1 As Long, c2 As Long ' Spalten#
Dim Zeit1 As Single, Zeit2 As Single
With ActiveSheet
nT = Day(DateSerial(Year(.Range("C3")), Month(.Range("C3")) + 1, 0)) ' Anzahl Tage im aktuellen Monat
c1 = 3 ' Spalte C = Start-Spalte
c2 = c1 + nT - 1 ' letzte Spalte Monatsbereich

If MsgBox("Wollen Sie die Einträge im Dienstplan wirklich löschen?", vbQuestion + vbYesNo, "Ehrwalder Almbahn") = vbYes Then
Zeit1 = Timer
Application.EnableEvents = False
.Range(.Cells(6, "C"), .Cells(58, c2)).ClearContents
Application.EnableEvents = True
Zeit1 = Timer - Zeit1: Zeit2 = Timer
Call Anzeigebereich_Löschen(ActiveSheet)
ActiveSheet.Range("C6").Select
Zeit2 = Timer - Zeit2
End If
End With
' MsgBox "Dauer Löschvorgang: " & Format(Zeit1, "0.00") & " plus " & Format(Zeit2, "0.00")
End Sub

Sub Anzeigebereich_Löschen(Sh As Worksheet)
' Version v 6.4 vom 04.03.2018
Dim nT As Long ' Anzahl Tage im Monat
Dim r As Long, Z As Long ' Zeilen#
Dim c As Long, c1 As Long, c2 As Long ' Spalten#
Dim d As Long ' Tagesdatum
Dim m As Long ' Monat
Dim ABereich As Range ' Anzeigebereich
Dim erg As Variant ' Ergebnis Match
Dim sZeit As Single

sZeit = Timer
With Sh
Select Case .name ' Name des aktuellen tabellenblattes
Case Is = "Januar", "Februar", "März", "April", "Dezember" 'Winterzeit
'=======================================================================================
' Anzeigebereich Zeilen 64:75 in Grundstellung setzen (Winterzeit)
'=======================================================================================

' Löschen und Einfärben Anzeigebereich in rot
nT = Day(DateSerial(Year(.Range("C3")), Month(.Range("C3")) + 1, 0)) ' Anzahl Tage im aktuellen Monat
c1 = 3 ' Spalte C = Start-Spalte
c2 = c1 + nT - 1 ' letzte Spalte Monatsbereich
Application.EnableEvents = False
With .Range("C64:AG75") ' maximaler Monatsbereich
.Interior.ColorIndex = xlNone
.ClearContents
End With
Application.EnableEvents = True
.Range(.Cells(64, "C"), .Cells(75, c2)).Interior.Color = 255
m = Month(.Range("C3")) ' Monats# der Tabelle

' Spezialbehandlung für Anlage Rodelabend, wenn Wintersaison
If m = 12 Or m
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

aloys78 · 12. März 2018

Hallo Mirko,

ich wollte das Jahr wechseln, dabei sollte es die Fehleranzeige in den Monatsblättern auch in Grundsellung bringen, das heisst es sollten die neuen Rodelabendtermine aus der Zwischenablage in die Fehleranzeige eingetragen werden.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Meinst Du mit Zwischablage das Tabellenblatt Zwischenspeicher ?

ist es richtig, dass es um die Prozedur Private Sub Button_Fertig_Click() geht ?
Wo liegt sie in Deiner Datei ?
wie wird sie gestartet ?

Nach einem Blick auf diesen Code, habe ich ihn gar nicht erst zu testen versucht.
Gründe:
- Du verwendest in Worksheets eine lfd. Nummer statt des Monatsnamens,
- Veränderungscode liegt außerhalb der Application.EnableEvents-Anweisung

Ich würde diesen Code dann etwas verändern und mit meiner Datei testen.

Gruß
Aloys

okrim · 12. März 2018

Hallo Aloys,

ich weiß es ist nicht perfekt mit meinem Code, da ich mich ja nicht wirklich auskenne hab ich es halt so gemacht, das es irgendwie funktioniert.

Ja mit Zwischenablage meinte ich Zwischenspeicher, sorry.

ist es richtig, dass es um die Prozedur Private Sub Button_Fertig_Click() geht ?
Wo liegt sie in Deiner Datei ?
wie wird sie gestartet ?
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Sie ist in einem userForm das öffnet wenn man die Jahreszahl ändert und wird gestartet mit einem Button.

Gruß Mirko

aloys78 · 12. März 2018

Hallo Mirko,

ich schicke Dir später mal den den überarbeiteten Code. Wenn ich das richtig sehe, brauchen wir beim Löschen nicht mehr zwischen Sommer und Winter zu unterscheiden.

Gruß
Aloys

okrim · 12. März 2018

Hallo Aloys,

das ist richtig das wir bei diesem Vorgang nicht mehr zwischen Winter und Sommer unterscheiden müssen. Da ich ja im Sommer die Spalte zwischen A und B eingefügt habe.

Sag schon mal danke, kann es halt erst heute abend wieder testen.

Gruß Mirko

aloys78 · 12. März 2018

Hallo Mirko,

nachstehend eine abgeänderte Version Deines Codes.
Dass Du die Datei vor der Änderung speicherst ist eine gute Idee.

Für den Test habe ich
- aber mal diesen Teil sowie die rot markierten Zeilen auskommentiert,
- aus Deiner Datei alle Monate ohne den Monatsspezifischen Code in einen eigenen Mosul meiner Datei übernommen
- die Prozedur nach dem Öffnen der Datei per Taste F5 aufgerufen
- Änderungen bei den Rodelabend-Terminen durchgeführt
- erneut mit F5 die Prozedur gestartet; die Änderungen sind im Anzeigeteil berücksichtigt

Bei 12 Tabellenblättern braucht die Prozedur bei mir (ohne Speichern) 0,3 Sek.
Braucht man dann noch die Userform ?

Gruß
Aloys
Code:

Option Explicit

Private Sub Button_Fertig_Click()
' Version V8 vom 13.03.2018

Dim nT As Long ' Anzahl Tage im Monat zum Diensplaneinträge löschen
Dim c As Long, c1 As Long, c2 As Long ' Spalten# zum Diensplaneinträge löschen
Dim i As Long ' Schleifenzähler
Dim a As Long ' Index Arrays
Dim p_arrSheet As Variant ' alle Monate
Dim Datum As Date ' Datum aus C3
Dim sZeit As Single ' Startzeit bei Zeitmessung

' Sheet-Array füllen
p_arrSheet = Array("Januar", "Februar", "März", "April", "Mai", "Juni", _
"Juli", "August", "September", "Oktober", "November", "Dezember")

'Schaut ob checkBox aktiv ist und Speichert die Datei neu an
' If Form_jahreswechsel.Controls("CheckBox1").Value = True Then

' ThisWorkbook.SaveAs (akt_pfad & "/" & neue_datei) 'Speichert die Datei
' MsgBox "Der Diensplan " & Sheets("Einstellungen").Range("D4") & " wurde unter " & akt_pfad & "/" & neue_datei & " gespeichert!" _
' , vbInformation, "Ehrwalder Almbahn"
' End If

'------------------------------------------------------------------------------------------
' Löscht sämtliche Diensplan Einträge inkl. Namen ausser die Namen unter Mitarbeiter
'------------------------------------------------------------------------------------------
sZeit = Timer
Application.ScreenUpdating = False ' Schaltet Diplay-Anzeige aus

' Dienstplan-Einträge für alle Monate löschen
For i = LBound(p_arrSheet) To UBound(p_arrSheet)
With ThisWorkbook.Worksheets(p_arrSheet(i))
Datum = .Range("C3") ' Startdatum aktueller Monat
nT = Day(DateSerial(Year(Datum), Month(Datum) + 1, 0)) ' Anzahl Tage im aktuellen Monat
c1 = 3 ' Spalte C = Start-Spalte
c2 = c1 + nT - 1 ' letzte Spalte Monatsbereich

Application.EnableEvents = False
.Range(.Cells(6, "C"), .Cells(58, c2)).ClearContents
.Range("A6:A58").ClearContents
Application.EnableEvents = True
End With
Next i

'------------------------------------------------------------------------------------------
' Setzt die Fehleranzeige für alle MOnate in Grundstellung
'------------------------------------------------------------------------------------------
Call Array_Aufbau ' Arrays werden neu aufgebaut, Änderungen in Zwischenspeicher werden berücksichtigt
For i = LBound(p_arrSheet) To UBound(p_arrSheet)
On Error Resume Next
ThisWorkbook.Worksheets(p_arrSheet(i)).Activate
If Err.Number 0 Then
MsgBox "Blatt " & ActiveSheet.Name & " wurde nicht gefunden !", vbCritical
Else
On Error GoTo 0
Call Anzeigebereich_Löschen(ActiveSheet) ' löscht Anzeigebereich für den Monat (Winter oder Sommer)
End If
Next i
On Error GoTo 0

'Springt in Tabellen Einstellungen
ThisWorkbook.Sheets("Einstellungen").Activate
Application.ScreenUpdating = True
MsgBox "Verarbeitungszeit Gesamt: " & Format(Timer - sZeit, "0.0")

'---------------------------------------------

Exit Sub
' Schaltet das Diplay Update ein
Application.ScreenUpdating = True
' Unload Me
'End If
'Unload Me
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

okrim · 13. März 2018

Hallo Aloys,

bin gerade dabei es zu testen und ich bekomme immer wieder Laufzeitfehler 5 Ungültiger Prozeduraufruf oder ungültiges Argument, ausser wenn ich die Datei schließe und neu öffne, dann kommt kein fehler.

Wenn ich auf Debuggen gehte wird im folgenden Code die rote Zeile Markiert.

Code:

Sub Anzeigebereich_Löschen(Sh As Worksheet)
' Version v 6.4 vom 04.03.2018
Dim nT As Long ' Anzahl Tage im Monat
Dim r As Long, Z As Long ' Zeilen#
Dim c As Long, c1 As Long, c2 As Long ' Spalten#
Dim d As Long ' Tagesdatum
Dim m As Long ' Monat
Dim ABereich As Range ' Anzeigebereich
Dim erg As Variant ' Ergebnis Match
Dim sZeit As Single

sZeit = Timer
With Sh
Select Case .name ' Name des aktuellen tabellenblattes
Case Is = "Januar", "Februar", "März", "April", "Dezember" 'Winterzeit
'=======================================================================================
' Anzeigebereich Zeilen 64:75 in Grundstellung setzen (Winterzeit)
'=======================================================================================

' Löschen und Einfärben Anzeigebereich in rot
nT = Day(DateSerial(Year(.Range("C3")), Month(.Range("C3")) + 1, 0)) ' Anzahl Tage im aktuellen Monat
c1 = 3 ' Spalte C = Start-Spalte
c2 = c1 + nT - 1 ' letzte Spalte Monatsbereich
Application.EnableEvents = False
With .Range("C64:AG75") ' maximaler Monatsbereich
.Interior.ColorIndex = xlNone
.ClearContents
End With
Application.EnableEvents = True
.Range(.Cells(64, "C"), .Cells(75, c2)).Interior.Color = 255
m = Month(.Range("C3")) ' Monats# der Tabelle

' Spezialbehandlung für Anlage Rodelabend, wenn Wintersaison
If m = 12 Or m
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Office: (Office 2010) Mit Makro kontrollieren ob bestimmte Werte vorhanden sind

Mit Makro kontrollieren ob bestimmte Werte vorhanden sind

Mit Makro kontrollieren ob bestimmte Werte vorhanden sind

Mit Makro kontrollieren ob bestimmte Werte vorhanden sind

Mit Makro kontrollieren ob bestimmte Werte vorhanden sind

Mit Makro kontrollieren ob bestimmte Werte vorhanden sind - Similar Threads - Makro kontrollieren bestimmte

Name der Datei durch Excel geändert

Ein Makro für mehrere Register

Makro öffnet unerwartete Datei

Leerzeilen entfernen

Makro Schaltflaechen vervielfaeltigen sich....

Seit Win 11 Zugriffsprobleme bei Excel über Makros

VBA-Makro zur Zellenformatierung Syntax probleme