Voorwaardelijke opmaak macro's combineren

[ajv12]

Hallo,

Ik probeer met VBA een voorwaardelijke opmaak te maken in een kalender. In dit bestand zit een besturingselement waarin je perioden kunt kiezen. De periode "pinksteren" geeft bijvoorbeeld een 4 als output waarna ik een code in VBA heb gezet die aan de hand van deze "4", de naastgelegen cellen een kleur geeft.

Ik wil ook dat in de kalender, alle dagen die in de pinksterperiode dezelfde kleur krijgen. Nu heb ik ook een code die daarvoor zorgt maar als ik beide codes combineer, dan krijg ik een foutmelding.

Ik heb beide code's opgesplitst in 2 bestanden en deze zijn met deze links te bereiken:

http://www.mijnbestand.nl/Bestand-EGJ88TMV3KV8.xls
http://www.mijnbestand.nl/Bestand-8JGBWPWRCKYN.xls

Kan iemand mij helpen deze 2 codes samen te voegen zodat:
- de invoervakjes van de data worden gekleurd
- en alle data in de kalender dezelfde kleur krijgen.

M.v.g.

AJV

 

[ajv12]

Het probleem is eigenlijk dat ik deze foutmelding krijg: dubbelzinnige naam: Worksheet_change.

De twee codes zijn:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

With Target

Select Case .Value
Case 1
Target.Offset(0, -12).Resize(1, 7).Interior.ColorIndex = 2
Case 2
Target.Offset(0, -12).Resize(1, 7).Interior.ColorIndex = 35
Case 3
Target.Offset(0, -12).Resize(1, 7).Interior.ColorIndex = 40
Case 4
Target.Offset(0, -12).Resize(1, 7).Interior.ColorIndex = 36
Case 5
Target.Offset(0, -12).Resize(1, 7).Interior.ColorIndex = 39
Case 6
Target.Offset(0, -12).Resize(1, 7).Interior.ColorIndex = 38
Case 7
Target.Offset(0, -12).Resize(1, 7).Interior.ColorIndex = 34
Case 8
Target.Offset(0, -12).Resize(1, 7).Interior.ColorIndex = 22
Case Else
.Interior.ColorIndex = xlNone
End Select

End With

End Sub

en

Private Sub Worksheet_Change(ByVal Target As Range)
'ActiveSheet.EnableSelection = xlUnlockedCells
Dim Cell As Range
Dim Rng1 As Range

On Error Resume Next
Set Rng1 = ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 1)
On Error GoTo 0
If Rng1 Is Nothing Then
Set Rng1 = Range(Target.Address)

End If
For Each Cell In Rng1
Select Case Cell.Value
Case [h2] To [l2]
Cell.Interior.ColorIndex = 35
Cell.Font.Bold = True
Case [h3] To [l3]
Cell.Interior.ColorIndex = 40
Cell.Font.Bold = True
Case [h4] To [l4]
Cell.Interior.ColorIndex = 35
Cell.Font.Bold = True
Case [h5] To [l5]
Cell.Interior.ColorIndex = 40
Cell.Font.Bold = True
Case [h6] To [l6]
Cell.Interior.ColorIndex = 35
Cell.Font.Bold = True
Case [h7] To [l7]
Cell.Interior.ColorIndex = 40
Cell.Font.Bold = True
Case [h8] To [l8]
Cell.Interior.ColorIndex = 35
Cell.Font.Bold = True
Case [h9] To [l9]
Cell.Interior.ColorIndex = 40
Cell.Font.Bold = True
Case [h10] To [l10]
Cell.Interior.ColorIndex = 40
Cell.Font.Bold = True
Case Else
Cell.Interior.ColorIndex = 2
Cell.Font.Bold = True
End Select
Next

End Sub

Weet iemand hoe deze twee codes gecombineerd kunnen worden?

Mvg

AJV

 

[ajv12]

Zojuist is het mij gelukt om de twee codes samen te voegen, maar nu is de code zo ontzettend groot, dat het heel veel tijd kost om hem uit te laten voeren.
Is er een manier om onderstaande code te vereenvoudigen, waardoor de werking sneller verloopt?

[CPP]Private Sub Worksheet_Change(ByVal Target As Range)
'ActiveSheet.EnableSelection = xlUnlockedCells
Dim Cell As Range
Dim Rng1 As Range

On Error Resume Next
Set Rng1 = ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 1)
On Error GoTo 0
If Rng1 Is Nothing Then
Set Rng1 = Range(Target.Address)

End If
For Each Cell In Rng1
Select Case Cell.Value
Case [H2] To [l2]
Cell.Interior.ColorIndex = [AU2]
Cell.Font.Bold = True

Case [h3] To [l3]
Cell.Interior.ColorIndex = [AU3]
Cell.Font.Bold = True
Case [h4] To [l4]
Cell.Interior.ColorIndex = [AU4]
Cell.Font.Bold = True
Case [h5] To [l5]
Cell.Interior.ColorIndex = [AU5]
Cell.Font.Bold = True
Case [h6] To [l6]
Cell.Interior.ColorIndex = [AU6]
Cell.Font.Bold = True
Case [h7] To [l7]
Cell.Interior.ColorIndex = [AU7]
Cell.Font.Bold = True
Case [h8] To [l8]
Cell.Interior.ColorIndex = [AU8]
Cell.Font.Bold = True
Case [h9] To [l9]
Cell.Interior.ColorIndex = [AU9]
Cell.Font.Bold = True
Case [h10] To [l10]
Cell.Interior.ColorIndex = [AU10]
Cell.Font.Bold = True

Case Else
Cell.Interior.ColorIndex = 2
Cell.Font.Bold = True
End Select
If [AT2] = 1 Then
[H2:L2].Interior.ColorIndex = 2
End If
If [AT2] = 2 Then
[H2:L2].Interior.ColorIndex = 39
End If
If [AT2] = 3 Then
[H2:L2].Interior.ColorIndex = 35
End If
If [AT2] = 4 Then
[H2:L2].Interior.ColorIndex = 38
End If
If [AT2] = 5 Then
[H2:L2].Interior.ColorIndex = 37
End If
If [AT2] = 6 Then
[H2:L2].Interior.ColorIndex = 36
End If
If [AT2] = 7 Then
[H2:L2].Interior.ColorIndex = 40
End If
If [AT2] = 8 Then
[H2:L2].Interior.ColorIndex = 22
End If
If [AT3] = 1 Then
[H3:L3].Interior.ColorIndex = 2
End If
If [AT3] = 2 Then
[H3:L3].Interior.ColorIndex = 39
End If
If [AT3] = 3 Then
[H3:L3].Interior.ColorIndex = 35
End If
If [AT3] = 4 Then
[H3:L3].Interior.ColorIndex = 38
End If
If [AT3] = 5 Then
[H3:L3].Interior.ColorIndex = 37
End If
If [AT3] = 6 Then
[H3:L3].Interior.ColorIndex = 36
End If
If [AT3] = 7 Then
[H3:L3].Interior.ColorIndex = 40
End If
If [AT3] = 8 Then
[H3:L3].Interior.ColorIndex = 22
End If
If [AT4] = 1 Then
[H4:L4].Interior.ColorIndex = 2
End If
If [AT4] = 2 Then
[H4:L4].Interior.ColorIndex = 39
End If
If [AT4] = 3 Then
[H4:L4].Interior.ColorIndex = 35
End If
If [AT4] = 4 Then
[H4:L4].Interior.ColorIndex = 38
End If
If [AT4] = 5 Then
[H4:L4].Interior.ColorIndex = 37
End If
If [AT4] = 6 Then
[H4:L4].Interior.ColorIndex = 36
End If
If [AT4] = 7 Then
[H4:L4].Interior.ColorIndex = 40
End If
If [AT4] = 8 Then
[H4:L4].Interior.ColorIndex = 22
End If
If [AT5] = 1 Then
[H5:L5].Interior.ColorIndex = 2
End If
If [AT5] = 2 Then
[H5:L5].Interior.ColorIndex = 39
End If
If [AT5] = 3 Then
[H5:L5].Interior.ColorIndex = 35
End If
If [AT5] = 4 Then
[H5:L5].Interior.ColorIndex = 38
End If
If [AT5] = 5 Then
[H5:L5].Interior.ColorIndex = 37
End If
If [AT5] = 6 Then
[H5:L5].Interior.ColorIndex = 36
End If
If [AT5] = 7 Then
[H5:L5].Interior.ColorIndex = 40
End If
If [AT5] = 8 Then
[H5:L5].Interior.ColorIndex = 22
End If
If [AT6] = 1 Then
[H6:L6].Interior.ColorIndex = 2
End If
If [AT6] = 2 Then
[H6:L6].Interior.ColorIndex = 39
End If
If [AT6] = 3 Then
[H6:L6].Interior.ColorIndex = 35
End If
If [AT6] = 4 Then
[H6:L6].Interior.ColorIndex = 38
End If
If [AT6] = 5 Then
[H6:L6].Interior.ColorIndex = 37
End If
If [AT6] = 6 Then
[H6:L6].Interior.ColorIndex = 36
End If
If [AT6] = 7 Then
[H6:L6].Interior.ColorIndex = 40
End If
If [AT6] = 8 Then
[H6:L6].Interior.ColorIndex = 22
End If
If [AT7] = 1 Then
[H7:L7].Interior.ColorIndex = 2
End If
If [AT7] = 2 Then
[H7:L7].Interior.ColorIndex = 39
End If
If [AT7] = 3 Then
[H7:L7].Interior.ColorIndex = 35
End If
If [AT7] = 4 Then
[H7:L7].Interior.ColorIndex = 38
End If
If [AT7] = 5 Then
[H7:L7].Interior.ColorIndex = 37
End If
If [AT7] = 6 Then
[H7:L7].Interior.ColorIndex = 36
End If
If [AT7] = 7 Then
[H7:L7].Interior.ColorIndex = 40
End If
If [AT7] = 8 Then
[H7:L7].Interior.ColorIndex = 22
End If
If [AT8] = 1 Then
[H8:L8].Interior.ColorIndex = 2
End If
If [AT8] = 2 Then
[H8:L8].Interior.ColorIndex = 39
End If
If [AT8] = 3 Then
[H8:L8].Interior.ColorIndex = 35
End If
If [AT8] = 4 Then
[H8:L8].Interior.ColorIndex = 38
End If
If [AT8] = 5 Then
[H8:L8].Interior.ColorIndex = 37
End If
If [AT8] = 6 Then
[H8:L8].Interior.ColorIndex = 36
End If
If [AT8] = 7 Then
[H8:L8].Interior.ColorIndex = 40
End If
If [AT8] = 8 Then
[H8:L8].Interior.ColorIndex = 22
End If
If [AT9] = 1 Then
[H9:L9].Interior.ColorIndex = 2
End If
If [AT9] = 2 Then
[H9:L9].Interior.ColorIndex = 39
End If
If [AT9] = 3 Then
[H9:L9].Interior.ColorIndex = 35
End If
If [AT9] = 4 Then
[H9:L9].Interior.ColorIndex = 38
End If
If [AT9] = 5 Then
[H9:L9].Interior.ColorIndex = 37
End If
If [AT9] = 6 Then
[H9:L9].Interior.ColorIndex = 36
End If
If [AT9] = 7 Then
[H9:L9].Interior.ColorIndex = 40
End If
If [AT9] = 8 Then
[H9:L9].Interior.ColorIndex = 22
End If
If [AT10] = 1 Then
[H10:L10].Interior.ColorIndex = 2
End If
If [AT10] = 2 Then
[H10:L10].Interior.ColorIndex = 39
End If
If [AT10] = 3 Then
[H10:L10].Interior.ColorIndex = 35
End If
If [AT10] = 4 Then
[H10:L10].Interior.ColorIndex = 38
End If
If [AT10] = 5 Then
[H10:L10].Interior.ColorIndex = 37
End If
If [AT10] = 6 Then
[H10:L10].Interior.ColorIndex = 36
End If
If [AT10] = 7 Then
[H10:L10].Interior.ColorIndex = 40
End If
If [AT10] = 8 Then
[H10:L10].Interior.ColorIndex = 22
End If
If [AT11] = 1 Then
[H11:L11].Interior.ColorIndex = 2
End If
If [AT11] = 2 Then
[H11:L11].Interior.ColorIndex = 39
End If
If [AT11] = 3 Then
[H11:L11].Interior.ColorIndex = 35
End If
If [AT11] = 4 Then
[H11:L11].Interior.ColorIndex = 38
End If
If [AT11] = 5 Then
[H11:L11].Interior.ColorIndex = 37
End If
If [AT11] = 6 Then
[H11:L11].Interior.ColorIndex = 36
End If
If [AT11] = 7 Then
[H11:L11].Interior.ColorIndex = 40
End If
If [AT11] = 8 Then
[H11:L11].Interior.ColorIndex = 22
End If
If [AT12] = 1 Then
[H12:L12].Interior.ColorIndex = 2
End If
If [AT12] = 2 Then
[H12:L12].Interior.ColorIndex = 39
End If
If [AT12] = 3 Then
[H12:L12].Interior.ColorIndex = 35
End If
If [AT12] = 4 Then
[H12:L12].Interior.ColorIndex = 38
End If
If [AT12] = 5 Then
[H12:L12].Interior.ColorIndex = 37
End If
If [AT12] = 6 Then
[H12:L12].Interior.ColorIndex = 36
End If
If [AT12] = 7 Then
[H12:L12].Interior.ColorIndex = 40
End If
If [AT12] = 8 Then
[H12:L12].Interior.ColorIndex = 22
End If

Next
End Sub[/CPP]Mvg,
AJV12

 

[OctaFish]

Doe ons een lol, en maak bovenstaande code op met de Code knop; nu krijg ik een lamme arm van het scrollen