VBA justering (betinget formattering af autoshapes)
Hej,Nedenstående VBA ændrer farverne på en række autoshapes.
Men for at eksekvere koden skal jeg aktivere cellerne i kolonne L eller M og trykke enter. Det er lidt træls når der er 20 ark. Data kommer automatisk ind via links.
=> Hvordan kan jeg ændre koden så den kører samlet? F.eks når man gemmer workbook?
=> Kan jeg evt lave en "samle-makro" som kører hver sheet-makro "on demand"?
mvh
Thomas
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myShape As Shape
Dim CellA As Range
Dim CellB As Range
Dim iCtr As Long
Dim myColor As Long
With Me
For iCtr = 1 To 12
Set myShape = Nothing
Set CellA = Nothing
Set CellB = Nothing
On Error Resume Next
Set myShape = .Shapes("Box" & iCtr)
Set CellA = .Range("L" & iCtr)
Set CellB = .Range("M" & iCtr)
On Error GoTo 0
If myShape Is Nothing _
Or CellA Is Nothing _
Or CellB Is Nothing Then
MsgBox "Design error with Object/CellA/CellB " & iCtr
Else
If Intersect(Target, Union(CellA, CellB)) Is Nothing Then
'do nothing
Else
If CellA.Value > CellB.Value Then
myColor = 17
ElseIf CellA.Value = CellB.Value Then
myColor = 18
Else
myColor = 16
End If
myShape.OLEFormat.Object.ShapeRange _
.Fill.ForeColor.SchemeColor = myColor
End If
End If
Next iCtr
End With
End Sub