MS-Office-Forum

Zurück   MS-Office-Forum > Microsoft Office > Microsoft Excel
Registrieren Forum Hilfe Alle Foren als gelesen markieren

Banner und Co.

Antworten
Ads
Themen-Optionen Ansicht
Alt 12.03.2018, 10:25   #91
okrim
Threadstarter Threadstarter
MOF User
MOF User
Standard

Hallo Aloys,

vielen Dank, werde es nach Feierabend gleich ausprobieren

Gruß Mirko
okrim ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 12.03.2018, 17:36   #92
okrim
Threadstarter Threadstarter
MOF User
MOF User
Standard

Hallo Aloys,

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

Gruß Mirko
okrim ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 12.03.2018, 17:51   #93
aloys78
MOF Meister
MOF Meister
Standard

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
aloys78 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 12.03.2018, 18:23   #94
okrim
Threadstarter Threadstarter
MOF User
MOF User
Standard

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

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

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 <= 4 Then            ' Winterzeit
                    Application.EnableEvents = False
                    For r = 65 To 67 Step 2
                        For c = c1 To c2
                            d = CLng(.Cells(3, c))        ' Datum der aktuellen Spalte
                            erg = Application.Match(d, p_ArrRT, 0)  ' Suche Tagesdatum im Array Rodelabend-Array
                            If Not IsNumeric(erg) Then              ' kein gültiger Rodelabend-Termin
                                .Cells(r, c).Interior.ColorIndex = xlNone
                                .Cells(r, c) = "X"
                            End If
                        Next c
                    Next r
                    Application.EnableEvents = True
                End If
            
            Case Is = "Mai", "Juni", "Juli", "August", "September", "Oktober", "November"   ' Sommerzeit
'=======================================================================================
'            Anzeigebereich Zeilen 64:65 in Grundstellung setzen (Sommerzeit)
'=======================================================================================
'             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(65, c2)).Interior.Color = 255
            
            Case Else
                Exit Sub                    ' kein Monatsblatt
        End Select
    
    End With
'    MsgBox Format(Timer - sZeit, "0.##")           ' Gesamtzeit für das Löschen des Tabellenblattes
End Sub
Habe aber auch eine komplette aktuelle Datei in der Dropbox.

Gruß Mirko
okrim ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 13.03.2018, 05:49   #95
aloys78
MOF Meister
MOF Meister
Standard

Hallo Mirko,

Zitat:

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.

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
aloys78 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 13.03.2018, 07:34   #96
okrim
Threadstarter Threadstarter
MOF User
MOF User
Standard

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.

Zitat:

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

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

Gruß Mirko
okrim ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 13.03.2018, 07:42   #97
aloys78
MOF Meister
MOF Meister
Standard

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
aloys78 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 13.03.2018, 08:14   #98
okrim
Threadstarter Threadstarter
MOF User
MOF User
Standard

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
okrim ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 13.03.2018, 10:40   #99
aloys78
MOF Meister
MOF Meister
Standard

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
aloys78 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 13.03.2018, 18:54   #100
okrim
Threadstarter Threadstarter
MOF User
MOF User
Standard

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 <= 4 Then            ' Winterzeit
                    Application.EnableEvents = False
                    For r = 65 To 67 Step 2
                        For c = c1 To c2
                            d = CLng(.Cells(3, c))        ' Datum der aktuellen Spalte
                            erg = Application.Match(d, p_ArrRT, 0)  ' Suche Tagesdatum im Array Rodelabend-Array
                            If Not IsNumeric(erg) Then              ' kein gültiger Rodelabend-Termin
                                .Cells(r, c).Interior.ColorIndex = xlNone
                                .Cells(r, c) = "X"
                            End If
                        Next c
                    Next r
                    Application.EnableEvents = True
                End If
            
            Case Is = "Mai", "Juni", "Juli", "August", "September", "Oktober", "November"   ' Sommerzeit
'=======================================================================================
'            Anzeigebereich Zeilen 64:65 in Grundstellung setzen (Sommerzeit)
'=======================================================================================
'             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(65, c2)).Interior.Color = 255
            
            Case Else
                Exit Sub                    ' kein Monatsblatt
        End Select
    
    End With
'    MsgBox Format(Timer - sZeit, "0.##")           ' Gesamtzeit für das Löschen des Tabellenblattes
End Sub
weißt du woran das liegen könnte???


Das Userform werde ich lassen, da darin steht das man Saison Anfang und Ende und die Rodelabendtermine eintragen muss, in dem Form sind dann auch gleich die Button dafür drauf, möchte es auch noch so machen das man "Button_Fertig_Click" erst betätigen kann wenn man alles eingetragen ist.

Gruß Mirko
okrim ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 13.03.2018, 21:11   #101
aloys78
MOF Meister
MOF Meister
Standard

Hallo Mirko,

Zitat:

weißt du woran das liegen könnte???

Nein - ich kenne ja Deine Testdatei nicht ?
Kannst Du mal den Testablauf näher beschreiben ?

Ansonsten läuft es denn wie gewünscht ?

Gruß
Aloys
aloys78 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 16.03.2018, 08:04   #102
okrim
Threadstarter Threadstarter
MOF User
MOF User
Standard

Hallo Aloys,

sorry das ich mich erst jetzt melde, bin die letzten Tage leider nicht dazu gekommen weiter zu machen.

Hab jetzt mal wieder bisschen getestet, so das ich dir eine vernünftige Antwort geben kann, komischerweise bekomme ich die Fehlermeldung jetzt nicht mehr, weis aber nicht warum, aber das ist ja gut so.

Wenn ich jezt den Jahreswechsel mache öffnet sich ja mein UserForm wo ich mit einem Button die Saison Anfang und Ende eingebe und wo ich mit einem anderen Button die Termin für den Rodelabend fest lege, danch gehe ich auf Button Fertig und es wir der Code ausgeführt den du mir als letztes gegeben hast.

Wenn ich das jetzt nacheinander abarbeite und auf fertig Klicke dann werden die Fehleranzeigen nicht aktualisiert es wird kein Rodelabend eingefügt, es wird alles mit X gefüllt, wenn ich aber alles nacheinander abarbeite dann nicht auf fertig sondern auf abbrechen und das ganze dann Speicher und schliese. Nach dem neu öffnen der Datei geht es auch nur wenn ich gleich in den Code für den Butten Fertig (den wo du mir geschickt hast) gehe und F5 drücke.

Ich weis nicht mehr weiter

Gruß Mirko
okrim ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 16.03.2018, 09:59   #103
aloys78
MOF Meister
MOF Meister
Standard

Hallo Mirko,

Zitat:

Wenn ich jezt den Jahreswechsel mache öffnet sich ja mein UserForm wo ich mit einem Button die Saison Anfang und Ende eingebe und wo ich mit einem anderen Button die Termin für den Rodelabend fest lege, danch gehe ich auf Button Fertig und es wir der Code ausgeführt den du mir als letztes gegeben hast.

Und wie war da das Ergebnis ?
Eigentlich sollten dann alle Monate in Grundstellung gesetzt worden sein !
Verstehe ich es richtig ?
- alle Rodelabend-Termin sind dann schon festgelegt
- Du hast den Code Button_Fertig_Click vom 13.3.18 im Einsatz
- Checkbox 1 ist True

Zitat:

Wenn ich das jetzt nacheinander abarbeite und auf fertig Klicke dann werden die Fehleranzeigen nicht aktualisiert es wird kein Rodelabend eingefügt, es wird alles mit X gefüllt, ...

Was machst Du da genau ?
Ist das eine andere als die oben beschriebene Vorgehensweise ?

Gruß
Aloys
aloys78 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 16.03.2018, 10:21   #104
okrim
Threadstarter Threadstarter
MOF User
MOF User
Standard

Hallo Aloys,

Zitat:

Und wie war da das Ergebnis ?

Es wird in der Fehleranzeige kein Rodelabend Termin eingetragen, es kommen nur X

Zitat:

Eigentlich sollten dann alle Monate in Grundstellung gesetzt worden sein !

Ja nur die Rodelabend Termine werden nicht eingetragen

Code:

Verstehe ich es richtig ?
- alle Rodelabend-Termin sind dann schon festgelegt Ja
- Du hast den Code Button_Fertig_Click vom 13.3.18 im Einsatz Ja
- Checkbox 1 ist True die habe ich komplett entfernt
Gruß Mirko
okrim ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 16.03.2018, 16:02   #105
aloys78
MOF Meister
MOF Meister
Standard

Hallo Mirko,

mit Deiner Datei kann ich nichts anfangen, da mir Verweise fehlen.
Insofern helfen mir auch Deine Anmerkungen nicht weiter.

Den Private Sub Button_Fertig_Click() ' Version V8 vom 13.03.2018 habe ich in deinem Code nicht gesehen. Er setzt alle Blätter (Sommer und Winter) in Grundstellung.

Im Sub Array_Aufbau() ' Version 6.4 vom 04.03.2018 solltest Du die erste Anweisung auskommentieren.
' check, ob Arrays schon aufgebaut sind
'If p_swArr = True Then Exit Sub ' Arrays sind schon aufgebaut


Gruß
Aloys
aloys78 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Ads
Antworten


Aktive Benutzer in diesem Thema: 1 (Registrierte Benutzer: 0, Besucher: 1)
 
Themen-Optionen
Ansicht

Forumregeln
Es ist Ihnen nicht erlaubt, neue Themen zu verfassen.
Es ist Ihnen nicht erlaubt, auf Beiträge zu antworten.
Es ist Ihnen nicht erlaubt, Anhänge anzufügen.
Es ist Ihnen nicht erlaubt, Ihre Beiträge zu bearbeiten.

vB Code ist An.
Smileys sind An.
[IMG] Code ist An.
HTML-Code ist An.
Gehe zu


Alle Zeitangaben in WEZ +1. Es ist jetzt 11:21 Uhr.


Partner und Co.
Access-Paradies -Alles rund um die Datenbank Microsoft Access -Code -Programme-Tools -Tipps   Kostenlose Tipps & Tricks, Downloads und Programme   www.kulpa-online.com - Tipps - Tricks - Tutorials - Meinungen - Downloads uvm...   vb@rchiv · Willkommen in der Welt der VB Programmierung   Access-Garhammer - Hier finden Sie jede Menge Beispiel-Datenbanken zu Access und mehr ...   mcseboard.de   Die Top Seite für Excel-VBA-Makros uvm.

Powered by: vBulletin Version 3.6.2 (Deutsch)
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.

Copyright ©2000-2018 MS-Office-Forum. Alle Rechte vorbehalten.
Copyright ©Design: Manuela Kulpa ©Rechte: Günter Kramer
Eine Verwendung der Inhalte in anderen Publikationen, auch auszugsweise,
ist ohne ausdrückliche Zustimmung der Autoren nicht gestattet.