18. januar 2010 - 14:36Der er
6 kommentarer og 1 løsning
Betinget formatering. Excel 7
Jeg har lavet betinget formatering sådan at hvis b1=1 så bliver c1 =rød (baggrunds farve) b1=2 så bliver c1 =gul b1=3 så bliver c1 =grøn b1=4 så bliver c1 =blå
Nej jeg kan ikke kopier det ned på alle de andre celler b2 og b3 osv så peger alle celler mod c1.
Et nyt nationalt initiativ fra Industriens Fond, EIFO og Innovationsfonden – eksekveret af DTU Science Park og Teknologisk Institut– skal bygge bro mellem startups, SMV’er og Forsvaret.
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Range("A1:A95"), Target) Is Nothing Then Application.ScreenUpdating = False ActiveSheet.Unprotect With Target Select Case Target.Value ' Et 1 tal i kolonne A, farver kolonne b rød i samme række Case "1" ActiveCell.Offset(-1, 1).Interior.ColorIndex = 3 ActiveCell.Offset(-1, 1).Font.ColorIndex = 1 ' Et 2 tal i kolonne A, farver kolonne b gul i samme række Case "2" ActiveCell.Offset(-1, 1).Interior.ColorIndex = 6 ActiveCell.Offset(-1, 1).Font.ColorIndex = 1 ' Et 3 tal i kolonne A, farver kolonne b grøn i samme række Case "3" ActiveCell.Offset(-1, 1).Interior.ColorIndex = 4 ActiveCell.Offset(-1, 1).Font.ColorIndex = 1 ' Et 4 tal i kolonne A, farver kolonne b blå i samme række Case "4" ActiveCell.Offset(-1, 1).Interior.ColorIndex = 5 ActiveCell.Offset(-1, 1).Font.ColorIndex = 1 Case Else ActiveCell.Offset(0, 5).Interior.ColorIndex = xlNone ActiveCell.Offset(0, 5).Font.ColorIndex = xlAutomatic End Select
End With End If Application.ScreenUpdating = True 'ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:=True End Sub
Nu er den rettet, (den er sakset fra et ark jeg selv bruger)
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Range("B1:B95"), Target) Is Nothing Then Application.ScreenUpdating = False ActiveSheet.Unprotect With Target Select Case Target.Value ' Et 1 tal i kolonne B, farver kolonne b rød i samme række Case "1" ActiveCell.Offset(-1, 1).Interior.ColorIndex = 3 ActiveCell.Offset(-1, 1).Font.ColorIndex = 1 ' Et 2 tal i kolonne B, farver kolonne b gul i samme række Case "2" ActiveCell.Offset(-1, 1).Interior.ColorIndex = 6 ActiveCell.Offset(-1, 1).Font.ColorIndex = 1 ' Et 3 tal i kolonne B, farver kolonne b grøn i samme række Case "3" ActiveCell.Offset(-1, 1).Interior.ColorIndex = 4 ActiveCell.Offset(-1, 1).Font.ColorIndex = 1 ' Et 4 tal i kolonne B, farver kolonne b blå i samme række Case "4" ActiveCell.Offset(-1, 1).Interior.ColorIndex = 5 ActiveCell.Offset(-1, 1).Font.ColorIndex = 1 Case Else ActiveCell.Offset(0, 1).Interior.ColorIndex = xlNone ActiveCell.Offset(0, 1).Font.ColorIndex = xlAutomatic End Select
End With End If Application.ScreenUpdating = True 'ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:=True End Sub
I det ark du skal bruge koden, højreklikker du på arkfanen og vælger "Vis programkode". I den tomme rude i højre side indsættes koden. (kopier og indsæt den). Denne er rettet så kolonne A farves efter hvad der står i kolonne B.
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Range("B1:B95"), Target) Is Nothing Then Application.ScreenUpdating = False ActiveSheet.Unprotect With Target Select Case Target.Value ' Et 1 tal i kolonne B, farver kolonne A rød i samme række Case "1" ActiveCell.Offset(-1, -1).Interior.ColorIndex = 3 ActiveCell.Offset(-1, -1).Font.ColorIndex = 1 ' Et 2 tal i kolonne B, farver kolonne A gul i samme række Case "2" ActiveCell.Offset(-1, -1).Interior.ColorIndex = 6 ActiveCell.Offset(-1, -1).Font.ColorIndex = 1 ' Et 3 tal i kolonne B, farver kolonne A grøn i samme række Case "3" ActiveCell.Offset(-1, -1).Interior.ColorIndex = 4 ActiveCell.Offset(-1, -1).Font.ColorIndex = 1 ' Et 4 tal i kolonne B, farver kolonne A blå i samme række Case "4" ActiveCell.Offset(-1, -1).Interior.ColorIndex = 5 ActiveCell.Offset(-1, -1).Font.ColorIndex = 1 Case Else ActiveCell.Offset(0, -1).Interior.ColorIndex = xlNone ActiveCell.Offset(0, -1).Font.ColorIndex = xlAutomatic End Select
End With End If Application.ScreenUpdating = True 'ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:=True End Sub
Synes godt om
Ny brugerNybegynder
Din løsning...
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
Ny bruger
Nybegynder
Opret
Preview
