alternative für die buttonmakros
20.09.2021 12:54:02
ralf_b
Hallo Kjell,
ich habe hier für dich einen! Ersatz für alle Buttonmakros auf deinen Maschinenblättern. Du solltest es dir wenigstens ansehen.
Beim Codedurchsehen ist mir aufgefallen das du ziemlich viel Code sparen könntest, wenn einige Vorgänge zusammengefasst werden.
Grundlage dafür ist aber auch das die Blätter den gleichen Aufbau haben.
Option Explicit
Const SHTW As String = "Wartungseintraege"
Dim shW As Worksheet
Sub Wartungeintragen()
Dim ButtonName As String, sTaetigkeit As String, sRythmus As String
Dim aktZeile As Long, freieZeile As Long, lColFund As Long
Dim i As Long, cnt As Long, rownr As Long
Dim icolour As Integer
Dim x As Range, rngFund As Range
Set shW = Worksheets(SHTW)
Application.ScreenUpdating = False
ActiveSheet.Unprotect "Wartung-TPM-ABM21"
shW.Unprotect "Wartung-TPM-ABM21"
'Werte aus Wartungsblatt in Variablen schreiben, falls benötigt.
ButtonName = Application.Caller
aktZeile = ActiveSheet.Shapes(ButtonName).TopLeftCell.Row
sRythmus = ActiveSheet.Range("B" & aktZeile)
sTaetigkeit = ActiveSheet.Range("c" & aktZeile)
'Debug.Print Application.Caller
If Range("E" & aktZeile) = vbNullString Then 'Melder als Pflichtfeld
MsgBox "kein Melder eingetragen", vbCritical & vbOKOnly, "Fehler"
Exit Sub
Else
If ActiveSheet.Cells(12, 4).Interior.ColorIndex = 3 Then
ActiveSheet.Buttons.Enabled = True
'Finden der Überschrift
Set rngFund = shW.UsedRange.Rows(1).Find(sTaetigkeit, lookat:=xlWhole, LookIn:=xlValues)
If Not rngFund Is Nothing Then
lColFund = rngFund.Column 'SpaltenNr der Überschrift
Set rngFund = Nothing
Else
MsgBox "Tätigkeit nicht gefunden", vbOKOnly & vbCritical, "Fehler"
Exit Sub
End If
With shW
'freieZeile ermitteln und Werte eintragen
freieZeile = .Cells(Rows.Count, lColFund).End(xlUp).Row + 1
.Cells(freieZeile, lColFund) = Range("E" & aktZeile).Valueg
.Cells(freieZeile, lColFund + 1).Value = Date
.Cells(freieZeile, lColFund + 2).Value = ActiveSheet.Name
ActiveSheet.Cells(aktZeile, "D").Interior.ColorIndex = 10
ActiveSheet.Cells(aktZeile, "E").ClearContents
End With
Else
ActiveSheet.Buttons.Enabled = False
End If
End If
Worksheets("Übersicht").Unprotect "Wartung-TPM-ABM21"
With ActiveSheet.UsedRange
'Farbe der Wartungen abgleichen
cnt = .Rows.Count * 2
icolour = 10
For i = 1 To cnt
Set x = .Cells(i, 4)
If x.Offset(, -1).Value vbNullString Then
If x.Interior.ColorIndex = 3 Then
icolour = 3
Exit For
End If
End If
Next
''Zeilenr in Übersichtsblatt ermitteln und Farbe setzen
rownr = getRowNumber("Übersicht", ActiveSheet.Name)
Worksheets("Übersicht").Cells(rownr, 12).Interior.ColorIndex = icolour
End With
ActiveSheet.Protect "Wartung-TPM-ABM21"
Worksheets("Wartungseintraege").Protect "Wartung-TPM-ABM21"
Worksheets("Übersicht").Protect "Wartung-TPM-ABM21"
Application.ScreenUpdating = True
Set x = Nothing
End Sub
Function getRowNumber(sSheetname As String, sMachine As String)
Dim x
With Worksheets(sSheetname)
If .Shapes.Count > 0 Then
For Each x In .Shapes
If x.AlternativeText = sMachine Then
getRowNumber = x.TopLeftCell.Row
Exit Function
End If
Next
Else
If .Buttons.Count > 0 Then
For Each x In .Buttons
If x.TextFrame.Text = sMachine Then
getRowNumber = x.TopLeftCell.Row
Exit Function
End If
Next
End If
End If
End With
End Function