vba-Problem

[ItsME]

Hallo,

wir nutzen hier eine schlecht bedienbare Excel-Tabelle um HO und Spätschichten zu erfassen.

ich habe diese nun kpl. überarbeitet und viele Automatismen eingefügt.

Nun aber strauchel ich.

Ich benöte ich VBA-Script, welches in ein Tabellenblatt (hier das erste (Name ändert sich in Abhängigkeit)) eingetragen werden soll.

Das Script soll das Datum im gleichen Blatt B2:F2 vergleichen mit den Feiertagen (durch formeln generiert) auf dem Arbeitsblatt 'Infos zu Arbeitszeiten'!J11:J29
und in der Spalte mit dem entsprechenden Datum 

B4:B5;B7:B14;B16:B25;B27:B36
C4:C5;C7:C14;C16:C25;C27:C36
D4:D5;D7:D14;D16:D25;D27:D36
E4:E5;E7:E14;E16:E25;E27:E36
F4:F5;F8;F10:F14;F16:F25;F27:F36

das Wort "Feiertag" eintragen... ohne die zugrundeliegende bedingte Formatierung zu zerstören.

Dies soll sich natürlich wieder rückgängig machen, wenn keine Übereinstimmung mehr da ist. 

I-Tüpfelchen wäre, wenn bei Maus-Over der Name des Feiertags angezeigt wird.. naja... wie gesagt... i-Tüpfelchen ;)

Dieses erste Blatt zieht seinen Namen aus A43... A43 bekommt seinen Namen aus ='Infos zu Arbeitszeiten'!E2 

Wenn das fertig ist, will ich es entsprechend der Kalenderwochen kopieren und jeweils anpassen... ich habe mehrmals darüber nachgedacht, aber dies ist in diesem Fall besser.

Jedes dann existierende Tabellenblatt will ich durch setzen eines "X" in 'Infos zu Arbeitszeiten'!F2:F54 dann ein-/ausblenden.

Ich bekomme weder gebacken, dass das Wort "Feiertag" eingetragen wird, noch das ich die Tabellenblätter ein-/ausblenden kann...

Hat wer von Euch ne Idee?

[schauan]

Hallöchen,

also erst mal eine Frage / ein Hinweis. Warum nicht alles auf einem Blatt?
Ich habe mal eine Kalender erstellt, der alles über bedingte Formatierungen, Verweise usw. ausgegeben hat. Der wäre auch flexibel für verschiedene Jahre und Bundesländer. Lediglich Ferientermine müsste man mit dieser Variante manuell aus dem Netz holen und eventuelle Schließtage eintragen. Daneben waren dann Mitarbeiter und deren Abwesenheiten zu führen, hab ich auf dem Bild weggelassen.

   

Wenn man unbedingt will, kann man den auch monatsweise zerpflücken.
Eine im prinzip leere Kopie kann man sich beiseite tun, um damit die Folgejahre anzulegen. Ist besser, als eine gefüllte Datei für ein Folgejahr zu leeren ...

Einmal erstellt, kann man so was immer wieder verwenden - die dadurch einmalig notwendige Erstellung per VBA zu programmieren, ist da eher müßig.

[ItsME]

Hi,

im Prinzip keine schlehcte Variante.

Jedoch wird die Tabelle nach Fertigstellung in Teams eingepflegt, da funktioneren viele bedingte Formatierungen nicht.. die vba-Scripte sollten laufen.

Auch wird diese Tabelle hier schon seit 2019 in dieser Form genutzt und es gab nur "sanfte" Änderungen... wen ich jetzt eine derart andere Version
bereit stellen würde.. oh man...

[Klaus-Dieter]

Hallo,

wieder einer vom Stamm "haben wir schon immer so gemacht". 

[ItsME]

Hi,

bin auch nur "ausführendes Organ" :(

Denke aber, dass die Ansicht in Teams übersichtlicher ist mit den aktuellen Layout ;)

[Kuwer]

Hallo,

Code:

Sub Feiertagekennzeichnen()
  Dim rngGesamt As Range, rngZ As Range
  With Tabelle1
    Set rngGesamt = .Range("B4:B5,B7:B14,B16:B25,B27:B36,C4:C5,C7:C14,C16:C25,C27:C36,D4:D5,D7:D14,D16:D25,D27:D36,E4:E5,E7:E14,E16:E25,E27:E36,F4:F5,F8,F10:F14,F16:F25,F27:F36")
    rngGesamt = ""
    For Each rngZ In .Range("B2:F2")
      If Not IsError(Application.Match(CLng(rngZ.Value), Tabelle3.Range("J11:J29"), 0)) Then
        Intersect(rngZ.EntireColumn, rngGesamt.EntireRow).Value = "Feiertag"
      End If
    Next rngZ
  End With
End Sub

Gruß, Uwe

[ItsME]

Hi Uwe,

hab den Code im Blatt gegen Deinen getauscht und Deinen reinkopiert kopiert

sieht jetzt so aus:

Code:

Private Sub Worksheet_Calculate()
    Dim Wert As Variant
    Wert = Me.Range("A43").Value
   
    If Wert <> Me.Name Then
        Me.Name = Wert
    End If
End Sub

Sub Feiertagekennzeichnen()
  Dim rngGesamt As Range, rngZ As Range
  With Tabelle1
    Set rngGesamt = .Range("B4:B5,B7:B14,B16:B25,B27:B36,C4:C5,C7:C14,C16:C25,C27:C36,D4:D5,D7:D14,D16:D25,D27:D36,E4:E5,E7:E14,E16:E25,E27:E36,F4:F5,F8,F10:F14,F16:F25,F27:F36")
    rngGesamt = ""
    For Each rngZ In .Range("B2:F2")
      If Not IsError(Application.Match(CLng(rngZ.Value), Tabelle3.Range("J11:J29"), 0)) Then
        Intersect(rngZ.EntireColumn, rngGesamt.EntireRow).Value = "Feiertag"
      End If
    Next rngZ
  End With
End Sub

leider passierte nix...

Also hab ich ihn über "Entwicklertools"->Marcos manuell ausgeführt...

Abgesehen davon, dass eine Automatik besser wäre, passiert nichts :(

[Rabe]

Hi,

Du glaubst doch nicht, dass Uwe den Code ohne zu testen ins Forum stellt?

Wenn ich den Code in Deine Beispieldatei einfüge zusätzlich zu dem bisherigen hinter dem Tabellenblatt und dann manuell starte, wird am 1.1. der Feiertag eingetragen.
Das ist dann für die Automation kein Problem, das Sub im Change-Ereignis an geeigneter Stelle aufzurufen.
oder z.B. so:

Microsoft Excel Objekt Tabelle1

Option Explicit 
 
Private Sub Worksheet_Activate() 
    Call Feiertagekennzeichnen 
End Sub 
 
Sub Feiertagekennzeichnen() 
  Dim rngGesamt As Range, rngZ As Range 
  With Tabelle1 
    Set rngGesamt = .Range("B4:B5,B7:B14,B16:B25,B27:B36,C4:C5,C7:C14,C16:C25,C27:C36,D4:D5,D7:D14,D16:D25,D27:D36,E4:E5,E7:E14,E16:E25,E27:E36,F4:F5,F8,F10:F14,F16:F25,F27:F36") 
    rngGesamt = "" 
    For Each rngZ In .Range("B2:F2") 
      If Not IsError(Application.Match(CLng(rngZ.Value), Tabelle3.Range("J11:J29"), 0)) Then 
        Intersect(rngZ.EntireColumn, rngGesamt.EntireRow).Value = "Feiertag" 
      End If 
    Next rngZ 
  End With 
End Sub 
 
Private Sub Worksheet_Calculate() 
    Dim Wert As Variant 
    Wert = Me.Range("A43").Value 
     
    If Wert <> Me.Name Then 
        Me.Name = Wert 
    End If 
End Sub 
 
Private Sub Worksheet_Change(ByVal Target As Range) 
    Dim InfosBlatt As Worksheet 
    Dim InfosBereich As Range 
    Dim ZielBereiche() As Range 
    Dim ZielBereich As Range 
    Dim ZielZeilen As Variant 
    Dim Wert As Variant 
    Dim i As Integer, j As Integer 
     
    On Error Resume Next 
    ' Überprüfen Sie, ob die Änderung in Zelle B2 stattgefunden hat 
    If Not Intersect(Target, Me.Range("B2")) Is Nothing Then 
        ' Arbeitsblätter setzen 
        Set InfosBlatt = ThisWorkbook.Sheets("Infos zu Arbeitszeiten") 
         
        ' Zellen und Bereiche definieren 
        Set InfosBereich = InfosBlatt.Range("J11:J29") 
         
        ' Zielbereiche definieren 
        ZielZeilen = Array("4:5", "7:14", "16:25", "27:36") 
        Redim ZielBereiche(Ubound(ZielZeilen)) 
        For i = Lbound(ZielZeilen) To Ubound(ZielZeilen) 
            Set ZielBereiche(i) = Me.Range("B" & ZielZeilen(i)) ' Verweis auf die aktuelle Tabelle 
        Next i 
         
        ' Vergleich und Einfügen durchführen 
        For Each Wert In InfosBereich 
            For i = Lbound(ZielBereiche) To Ubound(ZielBereiche) 
                Set ZielBereich = ZielBereiche(i) 
                For j = 1 To ZielBereich.Rows.Count 
                    If ZielBereich.Cells(j, 1).Value = Me.Range("B2").Value Then 
                        If ZielBereich.Cells(j, 1).Text <> "Feiertag" Then 
                            ZielBereich.Cells(j, 1).Value = "Feiertag" 
                        End If 
                    End If 
                Next j 
            Next i 
        Next Wert 
    End If 
    On Error GoTo 0 
End Sub 
 

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0

  Test-Tabelle.xlsb (Größe: 36,73 KB / Downloads: 5)

[schauan]

Hallöchen,

Jedoch wird die Tabelle nach Fertigstellung in Teams eingepflegt, da funktioneren viele bedingte Formatierungen nicht.. die vba-Scripte sollten laufen.

ich kenne das eher anders herum
Allerdings scheint das "Live-Excel" in Teams nicht mit dem "Online-Excel" identisch zu sein. Eventuell müsste man da an der Standard-App schrauben.
Privat nutze ich Teams nur zum Chatten, Bildschirm teilen ...

Es soll wohl mal diese Möglichkeit gegeben haben:

how-to-open-an-excel-file-on-teams-with-Microsoft Excel instead of Excel Online or Teams app?

und später dann so:

change-default-app-to-open-a-file-from-teams

Also hab ich ihn über "Entwicklertools"->Marcos manuell ausgeführt...
Abgesehen davon, dass eine Automatik besser wäre, passiert nichts :(

Die Angaben Tabelle1 und Tabelle3 passen (falls DU es nicht in die hochgeladene Datei eingefügt hast) ? Nur mal sicherheitshalber der Hinweis - Sheets("Tabelle1") und Tabelle1 müssen nicht dasselbe sein ...

---

sind denn in Teams auch Zellkommentare - bzw neudeutsch die Notizen beim drüberfahren zu sehen? Programmtechnisch sind das ja immer noch comments ...

Im Prinzip kann man Kommentare so handeln - Codes für Makros 1 bis 3 aus Aufzeichnung erstellt, Makro 4 per Hand programmiert.

Code:

Sub Makro1()
    'Erstellen
    Range("A1").AddComment
    Range("A1").Comment.Visible = False
    Range("A1").Comment.Text Text:="Schauan:" & Chr(10) & "Feiertag"
End Sub
Sub Makro2()
    'Aendern
    Range("A1").Comment.Text Text:="Schauan:" & Chr(10) & "Feiertage"
End Sub
Sub Makro3()
    'Loeschen
    Range("A1").Select
    Selection.ClearComments
End Sub
Sub Makro4()
    'Pruefung, ob eine Zelle in der Auflistung der Zellen mit Kommentar enthalten ist - hier Auflistung des gesamten Blattes
    If Not Intersect(Range("A1"), Cells.SpecialCells(xlCellTypeComments)) Is Nothing Then
    MsgBox "... hat Kommentar"
    End If
End Sub

[Rabe]

Hi André,

Dein Link 2 bringt folgende Meldung: