• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Cellen koppelen (kleur + tekst)

Status
Niet open voor verdere reacties.
S

Steve22

Gebruiker
Lid geworden
27 feb 2009
Berichten
18
Ik heb eigenlijk 3 vragen.

1. Dit is de macro die ik heb op dit moment:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
     
    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)
    Else
        Set Rng1 = Union(Range(Target.Address), Rng1)
    End If
    For Each Cell In Rng1
        Select Case Cell.Value
        Case vbNullString
            Cell.Interior.ColorIndex = xlNone
            Cell.Font.Bold = False
        Case 1
            Cell.Interior.ColorIndex = 3
            Cell.Font.Bold = True
        Case 2
            Cell.Interior.ColorIndex = 46
            Cell.Font.Bold = True
        Case 3
            Cell.Interior.ColorIndex = 6
            Cell.Font.Bold = True
        Case 4
            Cell.Interior.ColorIndex = 36
            Cell.Font.Bold = True
        Case 5
            Cell.Interior.ColorIndex = 35
            Cell.Font.Bold = True
            
        Case 6
            Cell.Interior.ColorIndex = 4
            Cell.Font.Bold = True
        Case 7
            Cell.Interior.ColorIndex = 50
            Cell.Font.Bold = True
        Case 8
            Cell.Interior.ColorIndex = 2
            Cell.Font.Bold = True
        Case 9
            Cell.Interior.ColorIndex = 1
            Cell.Font.Bold = True
      
        Case Else
            Cell.Interior.ColorIndex = xlNone
            Cell.Font.Bold = False
        End Select
    Next
     
End Sub

De kleuren en cijfers komen in kolom A maar ik wil dat de cel ernaast in kolom B dezelfde achtergrondkleur krijgt als de cel in kolom A. Ik heb vanalles geprobeerd maar ik kom er niet uit.

2. Daarnaast zit ik met het volgende: Ik heb 3 rijen, met elke de optie dat ze wel of niet een kleur krijgen in het geval dat een gegeven positief is. Ik wil dat de andere 2 rijen de tekst 'n.v.t.' automatisch krijgen zodra in 1 van de rijen een cel een kleur heeft gekregen. Dus bijvoorbeeld:
A1 B1 C1
groen n.v.t. n.v.t.
n.v.t. oranje n.v.t.
n.v.t. n.v.t. rood
In mijn bestand werk ik met deze 3 kleuren, de bedoeling is dus dat als ik groen selecteer in A1 (dmv valideren) dat de andere 2 cellen automatisch nvt krijgen.

3. Op zelfde manier wil ik een macro gebruiken dat zodra in A1, 1 wordt gekozen (rood), oftwel negatief, dat er vervolgens in bijvoorbeeld C1, D1, G1, J1 een - teken komt te staan omdat die optie in dat geval niet mogelijk is. Er zijn een aantal cellen/rijen die niet van toepassing zijn in zo'n geval maar een aantal wel, dus ik wil de cellen/rijen individueel kunnen aangeven.

Iemand die me hierbij kan helpen?

Vriendelijke bedankt,
Steve
 
Voor het kleuren van de naastgelegen cel:
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
     
    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)
    Else
        Set Rng1 = Union(Range(Target.Address), Rng1)
    End If
    For Each Cell In Rng1
        Select Case Cell.Value
        Case vbNullString
            Cell.Interior.ColorIndex = xlNone
            Cell.Font.Bold = False
        Case 1
            Cell.Interior.ColorIndex = 3
            Cell.Font.Bold = True
        Case 2
            Cell.Interior.ColorIndex = 46
            Cell.Font.Bold = True
        Case 3
            Cell.Interior.ColorIndex = 6
            Cell.Font.Bold = True
        Case 4
            Cell.Interior.ColorIndex = 36
            Cell.Font.Bold = True
        Case 5
            Cell.Interior.ColorIndex = 35
            Cell.Font.Bold = True
            
        Case 6
            Cell.Interior.ColorIndex = 4
            Cell.Font.Bold = True
        Case 7
            Cell.Interior.ColorIndex = 50
            Cell.Font.Bold = True
        Case 8
            Cell.Interior.ColorIndex = 2
            Cell.Font.Bold = True
        Case 9
            Cell.Interior.ColorIndex = 1
            Cell.Font.Bold = True
      
        Case Else
            Cell.Interior.ColorIndex = xlNone
            Cell.Font.Bold = False
        End Select
[B]        Cell.Offset(0, 1).Interior.ColorIndex = Cell.Interior.ColorIndex[/B]
    Next
     
End Sub

Alleen vetgedrukte gedeelte is toegevoegd.

Met vriendelijke groet,


Roncancio
 
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  On Error Resume Next
  with target.resize(,2).interior
    .colorindex=0
    .colorindex=choose(val(target.value),3,46,6,36,35,4,50,2,1)
  end with
  target.font.bold=val(target.value)>0 and err.number=0
  err.clear

  x=ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 1).count
  if err.number=0 then  
    For Each cl In ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 1)
      err.clear
      with cl.resize(,2).interior
        .colorindex=0
        .colorindex=choose(val(cl.value),3,46,6,36,35,4,50,2,1)
      end with
      cl.font.bold=val(cl.value)>0 and err.number=0
    next
  end if
End Sub
 
Laatst bewerkt:
@ Roncancio bedankt, het werkt perfect.

@ snb, ik snap niet waar die macro voor bedoelt is, mss dat je me wat uitleg verder kan geven want ik kom er niet verder mee.

Ik zit nog met vraag 2 en 3.
 
Mijn (aangepaste) suggestie doet hetzelfde als jouw code met oplossing voor je eerste vraag.
 
Update

Dit heb ik nu:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
     
    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)
    Else
        Set Rng1 = Union(Range(Target.Address), Rng1)
    End If
    For Each Cell In Rng1
        Select Case Cell.Value
        Case vbNullString
            Cell.Interior.ColorIndex = xlNone
            Cell.Font.Bold = False
        Case 1
            Cell.Interior.ColorIndex = 3
            Cell.Font.Bold = True
        Case 2
            Cell.Interior.ColorIndex = 46
            Cell.Font.Bold = True
        Case 3
            Cell.Interior.ColorIndex = 6
            Cell.Font.Bold = True
        Case 4
            Cell.Interior.ColorIndex = 36
            Cell.Font.Bold = True
        Case 5
            Cell.Interior.ColorIndex = 35
            Cell.Font.Bold = True
        Case 6
            Cell.Interior.ColorIndex = 4
            Cell.Font.Bold = True
        Case 7
            Cell.Interior.ColorIndex = 50
            Cell.Font.Bold = True
        Case 8
            Cell.Interior.ColorIndex = 2
            Cell.Font.Bold = True
        Case 9
            Cell.Interior.ColorIndex = 1
            Cell.Font.Bold = True
        Case "CAAML-proof"
            Cell.Interior.ColorIndex = 35
            Cell.Font.Bold = True
        Case "Statuten ontbreken"
            Cell.Interior.ColorIndex = 46
            Cell.Font.Bold = True
        Case "Niet CAAML-proof"
            Cell.Interior.ColorIndex = 3
            Cell.Font.Bold = True
        Case Else
            Cell.Interior.ColorIndex = xlNone
            Cell.Font.Bold = False
        End Select
        Cell.Offset(0, 1).Interior.ColorIndex = Cell.Interior.ColorIndex

    Next
     
End Sub

Ik wil echter bij de cases caaml-proof, statuten ontbreken en niet caaml-proof dat de cel ernaast niet dezelfde kleur krijgt. Wat ik graag wil is dat als in kolom F, caaml-proof wordt geselecteerd dat in kolom G en kolom H de tekst n.v.t. automatisch komt te staan. Hetzelfde geldt dat als statuten ontbreekt in kolom G wordt geselecteerd er automatisch n.v.t. in kolom F en kolom H komt te staan.

Ik heb ook nog geen duidelijke code kunnen vinden waarmee ik kolommen aan elkaar kan koppelen zodat als code 1 geselecteerd wordt verschillende kolommen n.v.t. automatisch krijgen...
 
Voor het gemak heb ik maar een voorbeeld bestandje gemaakt.

De bedoeling is dat als 1/rood gekozen wordt, er in E3, J3, K3, L3 automatisch n.v.t. komt te staan. Bij goed/twijfel/slecht is het de bedoeling dat zodra slecht gekozen wordt deze de kleur rood krijgt en dat twijfel en goed n.v.t. automatisch krijgen. Bij twijfel moet deze oranje worden en de andere n.v.t. krijgen en bij goed moet deze groen worden en de andere n.v.t. Daarnaast trek hij de kleuren nu daar ook door in de cellen ernaast (zie code hierboven), dat is niet de bedoeling in die cellen.
 

Bijlagen

Code: 
Sub status()
'
' status Macro
'

'
    ActiveWindow.SmallScroll ToRight:=3
    Range("E3").Select
    ActiveCell.FormulaR1C1 = "N.v.t."
    Range("H3").Select
    ActiveWindow.SmallScroll ToRight:=3
    Range("J3").Select
    Selection.Interior.ColorIndex = xlNone
    ActiveCell.FormulaR1C1 = "N.v.t."
    With ActiveCell.Characters(Start:=1, Length:=6).Font
        .Name = "Arial"
        .FontStyle = "Standaard"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    Range("K3").Select
    Selection.Interior.ColorIndex = xlNone
    ActiveCell.FormulaR1C1 = "N.v.t."
    With ActiveCell.Characters(Start:=1, Length:=6).Font
        .Name = "Arial"
        .FontStyle = "Standaard"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    Range("L3").Select
    Selection.Interior.ColorIndex = xlNone
    ActiveCell.FormulaR1C1 = "N.v.t."
    With ActiveCell.Characters(Start:=1, Length:=6).Font
        .Name = "Arial"
        .FontStyle = "Standaard"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    Range("L4").Select
End Sub
Sub Macro1()
'
' Macro1 Macro

'
    Range("G3").Select
    Selection.Interior.ColorIndex = xlNone
    Range("H3").Select
End Sub
Sub Macro2()
'
' Macro2 Macro
'

'
    Range("H4").Select
    Selection.Interior.ColorIndex = xlNone
    Range("G4").Select
    With Selection.Interior
        .ColorIndex = 45
        .Pattern = xlSolid
    End With
    Selection.Interior.ColorIndex = 46
End Sub
Sub Macro3()
'
' Macro3 Macro
'

'
    Range("I5").Select
    Selection.Interior.ColorIndex = xlNone
    Range("H5").Select
    With Selection.Interior
        .ColorIndex = 3
        .Pattern = xlSolid
    End With
    Range("H5").Select
End Sub

Ik heb weer wat geprobeerd maar verder dan dit kom ik niet. Hij wil het niet automatisch doen, is het niet mogelijk om automatisch iets uit een keuzelijst te laten kiezen?
 
Steve

Je maakt je het leven veel makkelijker als je al de onnodige troep eruit gooit.

Jouw macro status kan gewoon als:

Code: 
Sub status()
'
' status Macro
'
    Range("E3").Value = "N.v.t."
    
    With Range("J3:L3")
        .Interior.ColorIndex = xlNone
        .Value = "N.v.t."
        
        With .Font
            .Name = "Arial"
            .FontStyle = "Standaard"
            .Size = 10
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .ColorIndex = xlAutomatic
        End With
        
    End With
    
End Sub

en dit is zelfs nog veel te veel. Je kan bvb. een cel opmaken zoals je wil, en dan kopieren en plakken in code zodat de opmaak hetzelfde is en je niet in code al die eigenschappen zoals hierboven moet instellen. Dat maakt het ook makkelijker te onderhouden.

Wigi
 
Bedankt Wigi. Helaas ben ikzelf een leek in macro's dus het is echt vallen en opstaan voor mij. Ik probeer het dan ook met de opname methode.

Ik heb de macro status inprincipe nu werkende, alleen wil hij hem alleen uitvoeren in de derde rij (E3, J3, etc). Wat moet ik toevoegen zodat hij hem in alle rijen uitvoerd?

Deze code heb ik voor de andere statussen maar dat gaat helemaal mis als ik die probeer...
Code: 
Sub status2()
'
' status2 Macro
'

'
    ActiveCell.FormulaR1C1 = "CAAML-proof"
    Range("F3").Select
    Selection.Interior.ColorIndex = 35
    Range("G3").Select
    ActiveCell.FormulaR1C1 = "N.v.t."
    Range("H3").Select
    ActiveCell.FormulaR1C1 = "N.v.t."
    Range("H4").Select
End Sub
Sub Status3()
'
' Status3 Macro
'

'
    Selection.Interior.ColorIndex = xlNone
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    ActiveCell.FormulaR1C1 = "Statuten ontbreken"
    With ActiveCell.Characters(Start:=1, Length:=18).Font
        .Name = "Arial"
        .FontStyle = "Standaard"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    Range("G4").Select
    Selection.Interior.ColorIndex = 45
    Range("H4").Select
    Selection.ClearContents
    Selection.Interior.ColorIndex = xlNone
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    ActiveCell.FormulaR1C1 = "N.v.t."
    With ActiveCell.Characters(Start:=1, Length:=6).Font
        .Name = "Arial"
        .FontStyle = "Standaard"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    Range("F4").Select
    ActiveCell.FormulaR1C1 = "N.v.t."
    Range("G4").Select
    With Selection.Interior
        .ColorIndex = 45
        .Pattern = xlSolid
    End With
End Sub
Sub Status4()
'
' Status4 Macro

'

'
    ActiveCell.FormulaR1C1 = "Niet CAAML-proof"
    Range("I5").Select
    Selection.Interior.ColorIndex = xlNone
    Range("F5").Select
    ActiveCell.FormulaR1C1 = "N.v.t."
    Range("G5").Select
    ActiveCell.FormulaR1C1 = "N.v.t."
    Range("H5").Select
    With Selection.Interior
        .ColorIndex = 3
        .Pattern = xlSolid
    End With
End Sub
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan