29.07.2017, 16:24 (Dieser Beitrag wurde zuletzt bearbeitet: 29.07.2017, 16:45 von michel34497.)
Hallo! In meinen Projekt habe ich viele UF's Module und KlassenModule. Am anfang war ich froh über jeden select. Damit man den Code nachvollziehen kann, jetzt nervt es. Manche von Euch kenn das Projekt ja schon da ich es öfters schon angehagen habe. Ich suche jetzt nach einer Lösung wie ich mit den verschiedenen Code's die verschiedenen TabellenBlätter ansprchen kann. Also eine Variable die mir sagt welches TabellenBlatt. Um es genauer zu machen beschreibe ich mal eine Situation. Beim öffenen wird die Uf Start angezeigt, dort wählt man jezt mit Button die Wartung aus. Wenn Uf Wartung aufgerufen wird startet UserForm_Initialize als nächstes satrtet in der UserForm_Initialize die UF PB1 diese ruft dann die Progressbar1 (mld_Allgemein)auf.Dort wird mittels schleife jedesmal das TabellenBlatt select aufgerufen.
Code:
Sub Progressbar1() SW = ThisWorkbook.Sheets.Count 'Schrittweite festlegen Länge = 1 Schritt = PB1.Label1.Width / SW 'Schrittbreite pro Aktualisierung
For i = 4 To SW 'ab Tabellenblatt 4 Starten
mb = i 'Variable Sheets(i).Select Call DatumAk Call Zellenfarbe Länge = Länge + Schritt PB1.Label2.Width = Länge PB1.Label3.Caption = Format(i / SW, "0 %") DoEvents Next Application.Wait (Now + TimeValue("0:00:01")) Unload PB1 End Sub
und anschließen die Module. In den Modulen wird immer das angewählte Sheet bearbeitet. Ich brauche jezt was damit die Module wissen welchesl Sheet grade bearbeitet werden soll und diese dann mit dem Code Bearbeitet werden kann. Das ganze sollte für mehrere Uf's (Start, WartAus, usw.)möglich sein. Die Sub's DatumAk und Zellenfarbe werden aus meheren Uf's aufgefrufen. Ich hoffe es ist einigermassen verständlich. Wenn NICHT einfach nachfragen
Hallo! Leider habe ich wenig erfolg mit deinen Tip! Im Module mld_WartAus (Zellenfarbe) sollen dann noch die Registerfarben geändert werden. Das macht der Code nicht mehr und With Sheets(i) nimmt er auch nicht immer an. Was mache ich falsch? Hier erstmal der Code wo ich was geändert habe.
PHP-Code:
Sub Zellenfarbe(ByVal i As Integer) Dim AktuellesDatum As Date Dim Zelle As Range, c As Range Dim wksTab As Worksheet Dim liZeile As Integer Dim lz As Long, lngC As Long, a As Long Dim vntFarben As Variant
'SpalteDurchlaufen For Each Zelle In Sheets(i).Range("G10:G50") '& Cells(Rows.Count, "F").End(xlUp).Row) 'For Each Zelle In Range("G10:G50") '
If Zelle.Offset(0, -1) > 0 Then
If Zelle <> "" Then If Zelle <= Date Then 'Werte Vergleichen Zelle.Offset(0, -5).Interior.ColorIndex = 3 'Zelle rot einfärben Zelle.Offset(0, -4).Interior.ColorIndex = 3 'Zelle rot einfärben Zelle.Offset(0, -3).Interior.ColorIndex = 3 'Zelle rot einfärben 'ActiveSheet.Tab.ColorIndex = 3 'Register rot einfärben Else Tage = (Zelle - Date) 'Tage berechnen If Tage <= 7 Then 'Abfrage 7 Tage vorher Zelle.Offset(0, -5).Interior.ColorIndex = 27 'Zelle gelb einfärben Zelle.Offset(0, -4).Interior.ColorIndex = 27 'Zelle gelb einfärben Zelle.Offset(0, -3).Interior.ColorIndex = 27 'Zelle gelb einfärben Else Zelle.Offset(0, -5).Interior.ColorIndex = xlNone '-4105 'Zelle keine farbe Zelle.Offset(0, -4).Interior.ColorIndex = xlNone '-4105 'Zelle keine farbe Zelle.Offset(0, -3).Interior.ColorIndex = xlNone '-4105 'Zelle keine farbe End If End If Else If Zelle.Offset(0, -1) <> "" Then 'wenn in Zelle daneben kein Werte dann Zelle.Offset(0, -5).Interior.ColorIndex = 3 'Zelle rot einfärben Zelle.Offset(0, -4).Interior.ColorIndex = 3 'Zelle rot einfärben Zelle.Offset(0, -3).Interior.ColorIndex = 3 'Zelle rot einfärben End If End If End If 'Zelle.Select 'nur info wo der Code ist, wird nachher wieder gelöscht Next
With Sheets(i)
'Registerblatt einfärben lz = IIf(IsEmpty(Range("B65536")), Range("B65536").End(xlUp).Row, 65536) For lngC = 0 To UBound(vntFarben) a = 10 For Each c In Sheets(i).Range("B10:B" & lz).Cells If c.Interior.ColorIndex = vntFarben(lngC) Then If c.Interior.ColorIndex = -4105 Then GoTo weiter Sheets(i).Tab.ColorIndex = vntFarben(lngC) 'Register einfärben Exit For Else weiter: If Sheets(i).Tab.ColorIndex = 14 Then Else Sheets(i).Tab.ColorIndex = 14 'Zelle grün einfärben End If End If a = a + 1 Next c If a <= lz Then Exit For 'Prüfen ob c-Schleife abgebrochen wurde Next lngC
End With
End Sub Sub DatumAk(ByVal i As Integer) Dim AktuellesDatum As Date, datFrist As Date, datsecond As Date Dim Zelle As Range Dim strWieviel As String
'With Sheets(i) 'MsgBox Sheets(i).Name AktuellesDatum = Date 'SpalteDurchlaufen For Each Zelle In ThisWorkbook.Sheets(i).Range("H10:H50") 'mb kommt von der Progressbar als Variable 'For Each Zelle In Range("H10:H50") ' If Zelle <> "" Then datfirst = Zelle.Value 'Schreibe in Zelle strWieviel = Zelle.Offset(0, -2) 'die Anzahl der Monate If strWieviel > 0 Then datsecond = DateAdd("m", strWieviel, datfirst) 'DateAdd(Year(datfirst), Month(datfirst) + strWieviel, Day(datafirst)) Zelle.Offset(0, -1) = datsecond End If End If Next 'End With End Sub
Das nächste was ich dann noch hätte ist: Wenn in der UF WartAus ich im Label was was auswähle sollte der Codeteil das auch mitbekommen welches TabllenBlatt gerade bearbeitet werden soll.
PHP-Code:
Private Sub CommandButton2_Click()
Dim i, a, iActSheet, OlFilt As Integer Dim vZeile As Variant Dim letztespalte, rng, rngZelle As Range Dim KurzW, komm1, komm2 As String 'Kürzel für Wartung Dim AktuellesDatum As Date Dim Zeile As Long
iActSheet = ActiveSheet.Index 'Merken welches Tabellenblatt aktiv ist
If MitArbeiter > "" Then With WartAus.ListBox2 For i = 0 To .ListCount - 1 'Alle markierten ListBox-Einträge sammeln If WartAus.ListBox2.Selected(i) = True Then With ThisWorkbook.ActiveSheet vZeile = Application.Match(ListBox2.List(i, 1), .Columns(2), 0) Eintragen: Cells(vZeile, 8) = CDate(tbDatum) Cells(vZeile, 8).Offset(0, 1).Value = MitArbeiter KurzW = Cells(vZeile, 5).Value 'Kürzel der Wartung ermitteln Set rngZelle = Range("M2:CP3").Find(KurzW, lookat:=xlWhole, LookIn:=xlValues) 'Nach Kürzel suchen Cells(rngZelle.End(xlDown).Row + 1, rngZelle.End(xlDown).Column).Value = CDate(tbDatum) Cells(rngZelle.End(xlDown).Row, rngZelle.End(xlDown).Column + 1).Value = MitArbeiter If OlFilt = "Oel" Then GoTo Oel If OlFilt = "Filter" Then GoTo Filter If Cells(vZeile, 5).Value = "H_006" Then ' 'Wartung gefunden If MsgBox("Wurde ein Ölwechsel oder Filterwechsel durch gefürt?", vbQuestion + vbYesNo, _ "Titeltext, vbExclamation") = vbYes Then Wechsel.Show 'UF aufrufen If Wechsel.Oelwe = True Then 'Oelwechsel+Filterwechsel Unload Wechsel 'UF Schliesen For a = 1 To 2 vZeile = vZeile + 1 'Für Name und Datum eine Zeile in der Tabelle weiter schalten OlFilt = "Oel" GoTo Eintragen Oel: Next a Else 'Filterwechsel vZeile = vZeile + 2 OlFilt = "Filter" GoTo Eintragen Filter: End If OlFilt = "" Else 'MsgBox "Nein" Oelkontrolle.Show End If End If 'hier muss dann abgefragt werden ob es einen Kommentar gibt Set rng = Range("A:A").Find(KurzW) If rng Is Nothing Then 'MsgBox "Wert " & KurzW & " nicht gefunden!" Else komm1 = rng.Offset(0, 1) komm2 = rng.Offset(1, 1) 'rngZelle.End(xlDown).Select With .Cells(rngZelle.End(xlDown).Row, rngZelle.End(xlDown).Column + 1) .ClearComments .AddComment .Comment.Visible = False .Comment.Text Text:=komm1 & Chr(10) & komm2 .Comment.Shape.TextFrame.AutoSize = True ' Größe automatisch festlegen End With 'Löschen des Wortes Zeile = Columns("A:A").Find(KurzW, LookIn:=xlFormulas, _ lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False).Row
Range(Cells(Zeile, "A"), Cells(Zeile, "B")).Select Selection.Delete Shift:=xlUp End If
End With WartAus.ListBox2.Selected(i) = False End If Next i End With Else MsgBox "Kein Name ausgewählt" Exit Sub End If Call DatumAk(i) Call Zellenfarbe(i) Call Seitennamen AktuellesDatum = Date WartAus.Frame1.Clear Call colorC1 ThisWorkbook.Sheets(iActSheet).Activate 'Tabellenblatt wieder aktivieren Call suchenSpA End Sub
Aber erstmal zum anfang. Ich wieß ich habe einen riessssen Fehler gemacht das ich dies nicht gleich am anfang abgestellt habe. Ich hoffe Andre oder noch ein anderer kann helfen.
31.07.2017, 17:50 (Dieser Beitrag wurde zuletzt bearbeitet: 31.07.2017, 17:51 von schauan.)
Hallöchen,
zum ersten codebeispiel Bei With ... musst Du dann auch aufpassen, dass Du die Bereiche wie in meinem Beispiel mit einem "." referenzierst. Im ersten Makro ist da wohl noch eine Stelle, wo das fehlt: Statt
wobei die 65536 unflexibel noch aus "alten" Zeiten stammt. Hier kannst Du auch Rows.Count verwenden.
Deine zweite Schleife könnte bei Verwendung von With z.B. ungefähr so aussehen - beachte wiederum den "." vor Range und Tab
Code:
With Sheets(i) lz = IIf(IsEmpty(.Range("B65536")), .Range("B65536").End(xlUp).Row, 65536) For Each c In .Range("B10:B" & lz) ... .Tab.ColorIndex = vntFarben(lngC) 'Register einfärben ... Next End With
... wobei das With schon weiter oben vor die erste Schleife gestellt und diese dann auch entsprechend angepasst werden kann.
Mit den Variablen c und Zelle kannst Du eventuell auch was vereinheitlichen - falls die Schleifen nicht ineinander geschachtelt sind. Für spätere Änderungen wäre es auch von Vorteil, eine Linie in die Variablenbenennung zu bringen. Wenn Du gerne Zelle verwendest, könntest Du statt c und Zelle z.B. ZelleA und ZelleC verwenden (oder eventuell rngZelleA und rngZelleC)
Im Code hast Du z.B. auch
Code:
For Each c In Sheets(i).Range("B10:B" & lz).Cells For Each Zelle In ThisWorkbook.Sheets(i).Range("H10:H50")
Falls Du immer in ThisWorkbook bist, könntest Du das im zweiten Code entfallen lassen. Und wenn Du im zweiten Code die Erfahrung gemacht hast, dass er auch ohne .Cells den Bereich durchgeht, kannst Du es im ersten Fall vielleicht weglassen.
. \\\|/// Hoffe, geholfen zu haben. ( ô ô ) Grüße, André aus G in T ooO-(_)-Ooo (Excel 97-2019+365)
Hallo! Danke für die Hilfe, hat nich erstmal weiter gebracht. Funktioniert auch jetzt wieder mit den Register einfärben (nach den ersten Test). Den Rest muss ich mir erstmal noch richtig anschauen um das zu ändern. Ich würde jetzt gerne auf das problem mit dem Label weitergehen, wie könnte da dei Lösung aussehen?
