Arbeitsblattfarben in Zellen übernehmen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Färben() Dim BlattName As String Dim Zahl As Integer Dim Zelle As Range Dim sh As Worksheet For Each sh In ActiveWorkbook.Sheets BlattName = Replace(sh.Name, "Tabelle", "") If IsNumeric(BlattName) Then Zahl = CInt(BlattName) If Zahl > 0 Then Set Zelle = Cells.Find(what:=Zahl, lookat:=xlWhole) If Not Zelle Is Nothing Then Zelle.Offset(0, 1).Interior.ColorIndex = sh.Tab.ColorIndex End If End If End If Next End Sub

Sub Färben() Dim BlattName As String Dim Zelle As Range Dim sh As Worksheet For Each sh In ActiveWorkbook.Sheets BlattName = sh.Name Set Zelle = Cells.Find(what:=Blattname, lookat:=xlWhole) If Not Zelle Is Nothing Then Zelle.Offset(0, 1).Interior.ColorIndex = sh.Tab.ColorIndex End If Next End Sub

Hallo zusammen,
erst einmal vielen Dank an alle!
Die Markos von Jens/ Mark haben die Merkmale die ich gerne umgesetzt haben wollte!
Leider ist aber ein unerwartetes Problem aufgetaucht!
Das Marko Registerfarben sollte dazu dienen, eine "farbliche Untermalung" des Inhaltsverzeichnisses deutlich zu machen!
... Nun startet ich erst ein zweites Marko "Inhaltsverzeichnis". Diese löscht alle Butten im dem Ordner Inhalt. Der zuvor erzeugte Button Makro Registerfraben ist damit auch gelöscht ! Dies soll aber nicht passieren!
Es ist sicherlich schwer verständlich deshalb habe ich eine neue Datei erzeugt, die so hoffe ich alles verständlich macht!
https://www.herber.de/bbs/user/46066.xls
Main Idealfunktion würde sein, wenn das Marko Registerfarben in das Mako Inhaltsverzeichnis eingebunden würde? so würden die die Farben und Button immer neu angepasst!
Kann mann das noch umsetzten?
Gruß
Lemmi

Hallo Lemmi,
probier mal.
Sub Inhaltsverzeichnis()
Dim x As Integer, y As Integer, h As Integer, b As Integer, Btn As Object, _
    sh As Integer, shp As Shape, c As Integer, wshInhalt As Worksheet
Application.ScreenUpdating = False
h = 26: b = 150: x = 80: y = 40
'alte Button löschen
If InhaltExists = False Then
    Set wshInhalt = Worksheets.Add
    With wshInhalt
        .Move before:=Sheets(1)
        .Name = "Inhalt"
    End With
End If
Set wshInhalt = Worksheets("Inhalt")
On Error Resume Next
For Each shp In Sheets(1).Shapes
    If shp.Name Like "btn_*" Then
        'Registerfarbe löschen
        shp.TopLeftCell.Offset(0, -1).Interior.ColorIndex = 15
        shp.Delete
    End If
Next shp
On Error GoTo 0
c = 1
'neue Buttons einfügen
'button für Aktualisierung
Set Btn = wshInhalt.Buttons.Add(0, 0, b, h)
With Btn
    .Name = "btn_refresh"
    .OnAction = "Inhaltsverzeichnis"
    .Placement = xlFreeFloating
    .PrintObject = False
    .Characters.Text = "Auffrischen"
End With

For sh = 2 To Sheets.Count
    Set Btn = wshInhalt.Buttons.Add(x, y, b, h)
    With Btn
        .Name = "btn_" & Format(sh, "000")
        .OnAction = "activatesheet"
        .Placement = xlFreeFloating
        .PrintObject = True
        .Characters.Text = Sheets(sh).Name
    End With
    'Registerfarbe auslesen
    Btn.TopLeftCell.Offset(0, -1).Interior.Color = Sheets(sh).Tab.Color
    '"Zurück"-Button löschen
    On Error Resume Next
    Sheets(sh).Shapes("btnBack").Delete
    On Error GoTo 0
    '"Zurück"-Button auf jedes Blatt
    Set Btn = Sheets(sh).Buttons.Add(0, 23, 70, 15)
    With Btn
        .OnAction = "Back"
        .Characters.Text = "<<zurück<<"
        .Placement = xlFreeFloating
        .Name = "btnBack"
    End With
    ' immer nur 10 Buttons untereinander
    If c Mod 10 = 0 Then
        x = x + b + 55
        y = 40
        c = 1
    Else
        y = y + h + 10
        c = c + 1
    End If
Next sh
wshInhalt.Range("A1").Select
Application.ScreenUpdating = True
End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Arbeitsblattfarben in Zellen übernehmen

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread