• 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.

Voorwaardelijke opmaak via VBA?

Status
Niet open voor verdere reacties.
E

eefjek1986

Gebruiker
Lid geworden
27 sep 2012
Berichten
53
Hallo allemaal,

na dat ik de vorige keer zo goed geholpen ben, wil ik het nog eens proberen met 2 "kleine" probleempjes.

Het gaat om het volgende:
Ik heb een bestand waar ik in de Range A25:E-variabel- wat gegevens in moet plakken, zover geen probleem.
Maar in de Range A25:A274 heb, ik kan beter zeggen had, ik een voorwaardelijke opmaak voor 4 functie niveau`s (gekleurde cellen en cijfers v/d getallen 1 t/m 4).
Als ik nu namelijk nieuwe gegevens in de Range A25: bv E32 plak is mijn voorwaardelijk opmaak weg?
Kan ik dit met VBA bv zo ondervangen?

Code: 
With Target
Select Case .Value
Case 1
.Interior.ColorIndex = 3
Case 2
.Interior.ColorIndex = 5
Case 3
.Interior.ColorIndex = 4
Case 4
.Interior.ColorIndex = 15
Case 1
.Font.Color = 2
Case 2
.Font.Color = 44
Case 3
.Font.Color = 6
Case 4
.Font.Color = 3
Case Else
.Interior.ColorIndex = xlNone
End Select
End With

En kan zoiets worden ingevoegd in de volgende code?

Code: 
Option Explicit
Dim v
Dim I
Private Sub worksheet_Change(ByVal Target As Range)
  Dim Isect As Range, c As Range
  Application.EnableEvents = False

  Set Isect = Intersect(Target, Range("B25:C274"))
  If Not Isect Is Nothing Then
    For Each c In Isect.Cells: c.Value = Replace(LCase(c), " ", ""): Next
  End If

  Set Isect = Intersect(Target, Range("N25:FM274"))
  If Not Isect Is Nothing Then
    For Each c In Isect.Cells
      If Not IsNumeric(c) Then
 MsgBox "Hallo " & _
    UCase(Application.UserName) & " vul hier een getal in! ", _
   title:="                                  LDV ", Buttons:=vbCritical
       Target.ClearContents
       Application.Goto Target
        c.Select
        c.ClearContents
      End If
      Next
      End If
         I = Cells(Cells.Rows.Count, "A").End(xlUp).Row
   ActiveSheet.PageSetup.PrintArea = "A1:FM" & I
 Application.EnableEvents = True
 If Intersect(Target, Range("A25:FM274")) Is Nothing Then Exit Sub
 If Intersect(Target, Range("B25:B274")) Is Nothing Then Exit Sub
 
  If Intersect(Target, Range("B25:B274")) Is Nothing Then Exit Sub
  If v <> "" And Target.Value <> v Then
        Dim msg, style, title, response
        msg = " Dear " & LCase(Application.UserName) & ", the working-hours of " & UCase(v) & "  in Rij " & ActiveCell.Row & " wil be deleted! Do Your want to continue?"
        style = vbYesNo + vbDefaultButton2 + vbCritical
        title = " Are we going to delete?"
        response = MsgBox(msg, style, title)
        If response = vbYes Then
            msg = LCase(Application.UserName) & ", or would you like to save the data of " & UCase(v) & "  in Rij " & ActiveCell.Row & " first?"
            style = vbYesNo + vbDefaultButton1 + _
            vbCritical
            title = " Are we going to delete or save?"
            response = MsgBox(msg, style, title)
            If response = vbYes Then
                Application.Dialogs(xlDialogSaveAs).Show
            End If
            Application.EnableEvents = False
            Target.Offset(, -1).ClearContents
                    Target.Offset(, 1).ClearContents
                    Target.Offset(, 2).ClearContents
                    Target.Offset(, 3).ClearContents
                    Target.Offset(, 5).ClearContents
                    Target.Offset(, 12).ClearContents
                    Target.Offset(, 15).ClearContents
                    Target.Offset(, 18).ClearContents
                    Target.Offset(, 21).ClearContents
                    Target.Offset(, 24).ClearContents
                    Target.Offset(, 27).ClearContents
                    Target.Offset(, 30).ClearContents
                    Target.Offset(, 33).ClearContents
                    Target.Offset(, 36).ClearContents
                    Target.Offset(, 39).ClearContents
                    Target.Offset(, 42).ClearContents
                    Target.Offset(, 45).ClearContents
                    Target.Offset(, 48).ClearContents
                    Target.Offset(, 51).ClearContents
                    Target.Offset(, 54).ClearContents
                    Target.Offset(, 57).ClearContents
                    Target.Offset(, 60).ClearContents
                    Target.Offset(, 63).ClearContents
                    Target.Offset(, 66).ClearContents
                    Target.Offset(, 69).ClearContents
                    Target.Offset(, 72).ClearContents
                    Target.Offset(, 75).ClearContents
                    Target.Offset(, 78).ClearContents
                    Target.Offset(, 81).ClearContents
                    Target.Offset(, 84).ClearContents
                    Target.Offset(, 87).ClearContents
                    Target.Offset(, 90).ClearContents
                    Target.Offset(, 93).ClearContents
                    Target.Offset(, 96).ClearContents
                    Target.Offset(, 99).ClearContents
                    Target.Offset(, 102).ClearContents
                    Target.Offset(, 105).ClearContents
                    Target.Offset(, 108).ClearContents
                    Target.Offset(, 111).ClearContents
                    Target.Offset(, 114).ClearContents
                    Target.Offset(, 117).ClearContents
                    Target.Offset(, 120).ClearContents
                    Target.Offset(, 123).ClearContents
                    Target.Offset(, 126).ClearContents
                    Target.Offset(, 129).ClearContents
                    Target.Offset(, 132).ClearContents
                    Target.Offset(, 135).ClearContents
                    Target.Offset(, 138).ClearContents
                    Target.Offset(, 141).ClearContents
                    Target.Offset(, 144).ClearContents
                    Target.Offset(, 147).ClearContents
                    Target.Offset(, 150).ClearContents
                    Target.Offset(, 153).ClearContents
                    Target.Offset(, 156).ClearContents
                    Target.Offset(, 159).ClearContents
                    Target.Offset(, 162).ClearContents
                    Target.Offset(, 165).ClearContents
                                Application.EnableEvents = True
        Else
            Target = v
        End If
            Range("a25:FM274").Select
    Range("A25").Activate
    ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range("C25:C274") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range("B25:B274") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range("A25:A274") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(1).Sort
        .SetRange Range("A25:FM274")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A25").Select
   End If
   End Sub

Private Sub worksheet_selectionChange(ByVal Target As Range)
       v = Target.Value
 End Sub

Als 2de probleem dook het volgende op:
Als ik de gegevens heb geplakt krijg ik deze (zie bijlage)foutmelding in VBA heeft dan betrekking op de volgende regel.

Alvast mijn dank voor jullie hulp
 

Bijlagen

  • Naamloos.jpg
    Naamloos.jpg
    45 KB · Weergaven: 56
  • Naamloos1.jpg
    Naamloos1.jpg
    52,5 KB · Weergaven: 55
Eefje, vraag 1: ik denk dat je dit beoogt met de code:
Code: 
With Target
    Select Case .Value
        Case 1
            .Interior.ColorIndex = 3
            .Font.ColorIndex = 2
        Case 2
            .Interior.ColorIndex = 5
            .Font.ColorIndex = 44
        Case 3
            .Interior.ColorIndex = 4
            .Font.ColorIndex = 6
        Case 4
            .Interior.ColorIndex = 15
            .Font.ColorIndex = 3
        Case Else
            .Interior.ColorIndex = xlNone
            .Font.ColorIndex = xlAutomatic
        End Select
End With

Kan je deze code niet meteen aan het begin van je private sub plakken?

Vraag 2:
Je dimmed "v" en "I" buiten de private sub! Dat moet worden:
Code: 
Option Explicit
Private Sub worksheet_Change(ByVal Target As Range)
Dim v
Dim I
 
Hallo,

Een beetje dom? Maar waar moet ik het stuk Select Case in mijn code Plaatsen?


Groetjes,

Eefje:o
 
Hoi,

Als ik dit:
Code: 
Option Explicit
Private Sub worksheet_Change(ByVal Target As Range)
Dim v
Dim I

doe.

Krijg ik deze (bijlage) foutmelding?

Groetjes,

Eefje
 

Bijlagen

  • Naamloos.jpg
    Naamloos.jpg
    53,8 KB · Weergaven: 38
Dom? Nee hoor, er zijn geen domme vragen maar alleen domme antwoorden (heb ik niet van mijzelf). Per slot is het al laat, of vroeg hoe je het bekijkt.

Ik bedoel:

Code: 
Option Explicit
Private Sub worksheet_Change(ByVal Target As Range)
Dim v
Dim I

With Target
    Select Case .Value
        Case 1
            .Interior.ColorIndex = 3
            .Font.ColorIndex = 2
        Case 2
            .Interior.ColorIndex = 5
            .Font.ColorIndex = 44
        Case 3
            .Interior.ColorIndex = 4
            .Font.ColorIndex = 6
        Case 4
            .Interior.ColorIndex = 15
            .Font.ColorIndex = 3
        Case Else
            .Interior.ColorIndex = xlNone
            .Font.ColorIndex = xlAutomatic
        End Select
End With

en dan de rest van je code die je verderop hebt geplaatst.
 
De laatste foutmelding komt doordat je binnen die laatste private sub de variabele "v" niet hebt benoemd (dim v as ...).
 
Hallo Ronald,

ja het is laat of vroeg, het is maar hoe je het bekijkt.

Kijk eens naar de bijlagen!
Het loopt niet echt lekker, weet niet of het aan mijn kunsten ligt?
Ik hoor het wel, tot zover,

groetjes,

Eefje
 

Bijlagen

  • Naamloos.jpg
    Naamloos.jpg
    20,4 KB · Weergaven: 52
  • Naamloos1.jpg
    Naamloos1.jpg
    16,8 KB · Weergaven: 48
Eefje,

Voor wat betreft je eerste bijlage: zie post #6.
Voor wat betreft je tweede bijlage: wat loopt er niet bij die code?
 
Hallo Ronald,

als ik dit:
Code: 
Option Explicit
Private Sub worksheet_Change(ByVal Target As Range)
Dim v
Dim I
  Dim Isect As Range, c As Range
  Application.EnableEvents = False

  Set Isect = Intersect(Target, Range("B25:C274"))
  If Not Isect Is Nothing Then
    For Each c In Isect.Cells: c.Value = Replace(LCase(c), " ", ""): Next
  End If

  Set Isect = Intersect(Target, Range("N25:FM274"))
  If Not Isect Is Nothing Then
    For Each c In Isect.Cells
      If Not IsNumeric(c) Then
 MsgBox "Hallo " & _
    UCase(Application.UserName) & " vul hier een getal in! ", _
   title:="                                  LDV ", Buttons:=vbCritical
       Target.ClearContents
       Application.Goto Target
        c.Select
        c.ClearContents
      End If
      Next
      End If
         I = Cells(Cells.Rows.Count, "A").End(xlUp).Row
   ActiveSheet.PageSetup.PrintArea = "A1:FM" & I
 Application.EnableEvents = True
 If Intersect(Target, Range("A25:FM274")) Is Nothing Then Exit Sub
 If Intersect(Target, Range("B25:B274")) Is Nothing Then Exit Sub
 
  If Intersect(Target, Range("B25:B274")) Is Nothing Then Exit Sub
  If v <> "" And Target.Value <> v Then
        Dim msg, style, title, response
        msg = " Dear " & LCase(Application.UserName) & ", the working-hours of " & UCase(v) & "  in Rij " & ActiveCell.Row & " wil be deleted! Do Your want to continue?"
        style = vbYesNo + vbDefaultButton2 + vbCritical
        title = " Are we going to delete?"
        response = MsgBox(msg, style, title)
        If response = vbYes Then
            msg = LCase(Application.UserName) & ", or would you like to save the data of " & UCase(v) & "  in Rij " & ActiveCell.Row & " first?"
            style = vbYesNo + vbDefaultButton1 + _
            vbCritical
            title = " Are we going to delete or save?"
            response = MsgBox(msg, style, title)
            If response = vbYes Then
                Application.Dialogs(xlDialogSaveAs).Show
            End If
            Application.EnableEvents = False
            Target.Offset(, -1).ClearContents
                    Target.Offset(, 1).ClearContents
                    Target.Offset(, 2).ClearContents
                    Target.Offset(, 3).ClearContents
                    Target.Offset(, 5).ClearContents
                    Target.Offset(, 12).ClearContents
                    Target.Offset(, 15).ClearContents
                    Target.Offset(, 18).ClearContents
                    Target.Offset(, 21).ClearContents
                    Target.Offset(, 24).ClearContents
                    Target.Offset(, 27).ClearContents
                    Target.Offset(, 30).ClearContents
                    Target.Offset(, 33).ClearContents
                    Target.Offset(, 36).ClearContents
                    Target.Offset(, 39).ClearContents
                    Target.Offset(, 42).ClearContents
                    Target.Offset(, 45).ClearContents
                    Target.Offset(, 48).ClearContents
                    Target.Offset(, 51).ClearContents
                    Target.Offset(, 54).ClearContents
                    Target.Offset(, 57).ClearContents
                    Target.Offset(, 60).ClearContents
                    Target.Offset(, 63).ClearContents
                    Target.Offset(, 66).ClearContents
                    Target.Offset(, 69).ClearContents
                    Target.Offset(, 72).ClearContents
                    Target.Offset(, 75).ClearContents
                    Target.Offset(, 78).ClearContents
                    Target.Offset(, 81).ClearContents
                    Target.Offset(, 84).ClearContents
                    Target.Offset(, 87).ClearContents
                    Target.Offset(, 90).ClearContents
                    Target.Offset(, 93).ClearContents
                    Target.Offset(, 96).ClearContents
                    Target.Offset(, 99).ClearContents
                    Target.Offset(, 102).ClearContents
                    Target.Offset(, 105).ClearContents
                    Target.Offset(, 108).ClearContents
                    Target.Offset(, 111).ClearContents
                    Target.Offset(, 114).ClearContents
                    Target.Offset(, 117).ClearContents
                    Target.Offset(, 120).ClearContents
                    Target.Offset(, 123).ClearContents
                    Target.Offset(, 126).ClearContents
                    Target.Offset(, 129).ClearContents
                    Target.Offset(, 132).ClearContents
                    Target.Offset(, 135).ClearContents
                    Target.Offset(, 138).ClearContents
                    Target.Offset(, 141).ClearContents
                    Target.Offset(, 144).ClearContents
                    Target.Offset(, 147).ClearContents
                    Target.Offset(, 150).ClearContents
                    Target.Offset(, 153).ClearContents
                    Target.Offset(, 156).ClearContents
                    Target.Offset(, 159).ClearContents
                    Target.Offset(, 162).ClearContents
                    Target.Offset(, 165).ClearContents
                                Application.EnableEvents = True
        Else
            Target = v
        End If
            Range("a25:FM274").Select
    Range("A25").Activate
    ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range("C25:C274") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range("B25:B274") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range("A25:A274") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(1).Sort
        .SetRange Range("A25:FM274")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A25").Select
   End If
   End Sub

Private Sub worksheet_selectionChange(ByVal Target As Range)
       v = Target.Value
 End Sub
invoer, en ik wil iets plakken vanaf cel A25, krijg ik deze meldingen zie bijlagen:

Sorry maar wat moet ik veranderen binnen de code om te voldoen aan:

De laatste foutmelding komt doordat je binnen die laatste private sub de variabele "v" niet hebt benoemd (dim v as ...).

Groetjes,

Eefje
 

Bijlagen

  • Begrijp het niet1.jpg
    Begrijp het niet1.jpg
    36,6 KB · Weergaven: 49
Laatst bewerkt:
Eefje, de onderstaande code geeft een foutmelding omdat je daar met een variabele "v" werkt die niet gedeclareerd is.
Code: 
Private Sub worksheet_selectionChange(ByVal Target As Range)
       v = Target.Value
 End Sub
Deze code wordt al aangeroepen zodra je andere cel selecteert/aanklikt (SelectionChange) en heeft op zich niet te maken met de invoer. Als je er dit van maakt is die foutmelding weg:
Code: 
Private Sub worksheet_selectionChange(ByVal Target As Range)
Dim v  'declareer variabele "v"
       v = Target.Value
 End Sub

Kan je dit stukje niet binnen de "Private Sub worksheet_Change(ByVal Target As Range)" halen? Zoiets:
Code: 
Private Sub worksheet_Change(ByVal Target As Range)
Dim v
Dim I
    v = Target.Value
    With Target
    Select Case .Value
        Case 1
            .Interior.ColorIndex = 3
            .Font.ColorIndex = 2
        Case 2
            .Interior.ColorIndex = 5
            .Font.ColorIndex = 44
        Case 3
            .Interior.ColorIndex = 4
            .Font.ColorIndex = 6
        Case 4
            .Interior.ColorIndex = 15
            .Font.ColorIndex = 3
        Case Else
            .Interior.ColorIndex = xlNone
            .Font.ColorIndex = xlAutomatic
        End Select
End With
    'en dan hier de rest van je code
Op die manier heb je alles binnen één procedure en kan je die met SelectionChange verwijderen.
 
Hallo Ronald,

het werkt allemaal niet zo soepel!
Helaas kan ik jou geen privé bericht sturen omdat ik (nog)geen verenigingslid ben.
Zou jij, bij wijze van uitzondering, een naar mijn bestand willen kijken?
Ik kan het alleen niet op het forum plaatsen omdat het te groot is.
Laat mij even weten of ik het jou persoonlijk mag mailen, ik zou dit trouwens wel heel erg aardig vinden.
Mijn mailadres is eefjek1986@gmail.com.

Hopelijk wil en/of kun jij even kijken, alvast veel dank.


Groetjes,

Eefje
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan