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

active cel +1

Status
Niet open voor verdere reacties.
C

cor.de.kruijf

Gebruiker
Lid geworden
5 mrt 2001
Berichten
233
Hallo, ik probeer al een tijdje voorelkaar te krijgen om middels vba vanuit een willekeurige cel 1cel omlaag te springen, in deze cel de tekst kleur te wijzigen, daarna 1cel naar rechts voor hetzelfde en tot slot 1cel omhoog.
Via macrorecorder lukt het wel maar dan zijn de cellen niet willekeurig.
Heeft iemand een idee hoe ik dat voor elkaar kan krijgen?

Code: 
Range("A1:A2").Select
    ActiveSheet.Unprotect
    Cells.Find(What:="TEST", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, _
        SearchFormat:=False).Activate
    Range("H5").Select
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    Range("I5").Select
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    Range("I4").Select
    Cells.Find(What:="TEST", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, _
        SearchFormat:=False).Activate
    Range("N5").Select
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    Range("O5").Select

en zo verder, het is dus de bedoeling om in de sheet het woord "TEST" te vinden en vervolgens onderstaande en rechts van onderstaande de tekstkleur te wijzigen.
 
Hier een voorzet.

Code: 
ActiveSheet.Unprotect
     Set c = Cells.Find(What:="TEST", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, _
        SearchFormat:=False)
    With Cells(c.Row, c.Column).Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    With Cells(c.Row, c.Column).Offset(0, 1).Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
 
Superzeeuw zei:
Hier een voorzet.

Code: 
ActiveSheet.Unprotect
     Set c = Cells.Find(What:="TEST", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, _
        SearchFormat:=False)
    With Cells(c.Row, c.Column).Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    With Cells(c.Row, c.Column).Offset(0, 1).Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
Klik om te vergroten...

Dit is een waardevolle opzet :thumb:
ik heb hem nu zo gemaakt:
Application.ScreenUpdating = False


Code: 
 Range("A1:A2").Select
  ActiveSheet.Unprotect
     Set c = Cells.Find(What:="TEST", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, _
        SearchFormat:=False)
    With Cells(c.Row, c.Column).Offset(1, 0).Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
      With Cells(c.Row, c.Column).Offset(1, 1).Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With

  Application.ScreenUpdating = True
  ActiveSheet.Protect
End Sub

Nu moet ik deze zoekactie + bewerking enkele malen herhalen, in een loop dus.
Alleen...hoe pak ik dat aan, heb te weinig kennis helaas.
 
Laatst bewerkt door een moderator:
Dan zou het als volgt moeten kunnen werken voor jou.

Application.screenupdating is hier niet nodig omdat er niets geselecteerd en/of geactiveerd wordt.
De eerste regel Range("A1:A2").select is ook overbodig.

Code: 
Sub test()
    ActiveSheet.Unprotect
    Set c = Cells.Find("TEST", LookIn:=xlValues)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                With Cells(c.Row, c.Column).Resize(2, 2).Font
                    .ThemeColor = xlThemeColorDark1
                    .TintAndShade = 0
                End With
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
End Sub
 
wat ben jij snel zeg

Superzeeuw zei:
Dan zou het als volgt moeten kunnen werken voor jou.

Application.screenupdating is hier niet nodig omdat er niets geselecteerd en/of geactiveerd wordt.
De eerste regel Range("A1:A2").select is ook overbodig.

Code: 
Sub test()
    ActiveSheet.Unprotect
    Set c = Cells.Find("TEST", LookIn:=xlValues)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                With Cells(c.Row, c.Column).Resize(2, 2).Font
                    .ThemeColor = xlThemeColorDark1
                    .TintAndShade = 0
                End With
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
End Sub
Klik om te vergroten...

De vorige opzet kon ik nog volgen maar nu.......
Het werkt perfect op een kleinigheidje na wat ik in de vorige opzet nog wel kon rechtzetten.
Het zoekresultaat wordt nl ook gewijzigd, en dat is niet de bedoeling.
In je eerste opzet gebeurde dat ook, maar toen snapte ik het nog en kon ik het wijzigen.
Ik ben er bijna, ben al zeer tevreden en onder de indruk. :o
 
Dan zou het zo goed moeten zijn.

Code: 
Sub test()
    ActiveSheet.Unprotect
    Set c = Cells.Find("TEST", LookIn:=xlValues)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                With Cells(c.Row, c.Column).Offset(1, 0).Font
                    .ThemeColor = xlThemeColorDark1
                    .TintAndShade = 0
                End With
                With Cells(c.Row, c.Column).Offset(1, 1).Font
                    .ThemeColor = xlThemeColorDark1
                    .TintAndShade = 0
                End With
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
End Sub
 
Opgelost

cor.de.kruijf zei:
De vorige opzet kon ik nog volgen maar nu.......
Het werkt perfect op een kleinigheidje na wat ik in de vorige opzet nog wel kon rechtzetten.
Het zoekresultaat wordt nl ook gewijzigd, en dat is niet de bedoeling.
In je eerste opzet gebeurde dat ook, maar toen snapte ik het nog en kon ik het wijzigen.
Ik ben er bijna, ben al zeer tevreden en onder de indruk. :o
Klik om te vergroten...

Ik ben eruit!!

Sub test()
ActiveSheet.Unprotect
Set c = Cells.Find("TEST", LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False)
If Not c Is Nothing Then
firstAddress = c.Address
Do
With Cells(c.Row, c.Column).Offset(1, 0).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With Cells(c.Row, c.Column).Offset(1, 1).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Set c = Cells.FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
ActiveSheet.Protect
Range("A1:A2").Select

End Sub

Heel hartelijk bedankt voor je hulp Superzeeuw :thumb::thumb::thumb:
 
Mooi gedaan.

Op de valreep heb je het dan toch nog zelf opgelost.

Ga zo door.
 
Ingebouwde functie zijn doorgaans sneller dan wanneer je zelf iets bedenkt. Maar ik wou er toch even op wijzen dat je bv. ook op deze manier alle cellen in het gewenste bereik kunt langslopen:
Code: 
Sub macro1()
Dim cl As Range
'Deze macro is geschreven door Zapatr
For Each cl In Range("A1:M100")
If cl.Value = "TEST" Then
With Range(cl, cl.Offset(0, 1)).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End with
With cl.Offset(-1, 1).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End with
End If
Next cl
End Sub
Opmerkingen:
- Pas het bereik A1:M100 aan aan het gewenste bereik in jouw bestand.
- 'Themecolor' wordt door Excel 2002/2003 (waar ik mee werk) niet herkend, let daar op als het bestand ook voor mensen bestemd is die niet met Excel 2007 of 2010 werken.
- 'TinAndShade' de waarde 0 geven lijkt mij alleen nuttig als het vóór uitvoering van de macro die waarde NIET had. Maar dat is wellicht het geval.
- Als de cellen waarin TEST staat, kunnen wijzigen, dan moet je aan het begin van de macro in het gedefinieerde bereik 'ThemeColor' en 'TinAndShade' instellen op de standaardwaarden.
 
Laatst bewerkt:
waardevolle aanvulling!

zapatr zei:
Ingebouwde functie zijn doorgaans sneller dan wanneer je zelf iets bedenkt. Maar ik wou er toch even op wijzen dat je bv. ook op deze manier alle cellen in het gewenste bereik kunt langslopen:
Code: 
Sub macro1()
Dim cl As Range
'Deze macro is geschreven door Zapatr
For Each cl In Range("A1:M100")
If cl.Value = "TEST" Then
With Range(cl, cl.Offset(0, 1)).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End with
With cl.Offset(-1, 1).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End with
End If
Next cl
End Sub
Opmerkingen:
- Pas het bereik A1:M100 aan aan het gewenste bereik in jouw bestand.
- 'Themecolor' wordt door Excel 2002/2003 (waar ik mee werk) niet herkend, let daar op als het bestand ook voor mensen bestemd is die niet met Excel 2007 of 2010 werken.
- 'TinAndShade' de waarde 0 geven lijkt mij alleen nuttig als het vóór uitvoering van de macro die waarde NIET had. Maar dat is wellicht het geval.
- Als de cellen waarin TEST staat, kunnen wijzigen, dan moet je aan het begin van de macro in het gedefinieerde bereik 'ThemeColor' en 'TinAndShade' instellen op de standaardwaarden.
Klik om te vergroten...

De cellen met "TEST" veranderen idd nogal eens, dus hartelijk dank voor deze aanvulling Zapatr :d
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan