Hoe kan ik een VBA code verkorten?

kaan · 11 nov 2014

Allen,

Met de beperkte kennis wat ik heb heb ik een code kunnen creëren waarmee ik een aantal handelingen uitvoer.
Alles werkt prima maar ik zit met een volgende probleem.

Ik heb 2 verschillende Checkboxen waarmee ik 80 keer de zelfde handeling uitvoer.
Hierdoor heb ik in VBA 80 keer de zelfde code moeten herhalen en daardoor is mijn Excel file nu al ruim 150 KB. Als ik al mijn code hierin verwerkt heb word het waarschijnlijk zeker groter dan 500kb en hierdoor weer erg traag op een server.

Er is en zal vast wel een trucje zijn waarmee mijn code korter en simpeler word!

Wie kan en wil mij hiermee helpen?

Kaan

Niels28 · 11 nov 2014

opzet voor kolom F (dubbelklik in de cel waar normaal de checkbox zou staan.)
Kolom E moet ik nog doen maar heb vanmiddag pas weer tijd.

Bekijk bijlage Deplist-5 (1).xlsm

Niels

kaan · 11 nov 2014

Goedemorgen Niels,

Dit is inderdaad beter dan 80 keer de zelfde code herhalen. Goed begin!

Ik heb je code aangepast naar volgende:

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    If Not Intersect(Target, Range("F6,F11,F16,F21,F26,F31,F36,F41,F46,F51,F56,F61,F66,F71,F76,F81,F86,F91,F96,F101,F106,F111,F116,F121,F126,F131,F136,F141,F146,F151,F156,F161,F166,F171,F176,F181,F186,F191,F196")) Is Nothing Then
    Target.Value = IIf(Target.Value = "R", "Q", "R")
         With Target.Offset(3, 1)
            If Target.Value = "R" Then
                .Interior.Color = RGB(255, 255, 153)
                .Font.Color = RGB(255, 0, 0)
                .Font.Name = "Arial"
                .Value = "binnen"
            Else
                .Value = ""
                .Interior.Color = RGB(255, 255, 255)
            End If
        End With
    End If
    
     If Not Intersect(Target, Range("F201,F206,F211,F216,F221,F226,F231,F236,F241,F246,F251,F256,F261,F266,F271,F276,F281,F286,F291,F296,F301,F306,F311,F316,F321,F326,F331,F336,F341,F346,F351,F356,F361,F366,F371,F376,F381,F386,F391,F396,F401")) Is Nothing Then
    Target.Value = IIf(Target.Value = "R", "Q", "R")
         With Target.Offset(3, 1)
            If Target.Value = "R" Then
                .Interior.Color = RGB(255, 255, 153)
                .Font.Color = RGB(255, 0, 0)
                .Font.Name = "Arial"
                .Value = "binnen"
            Else
                .Value = ""
                .Interior.Color = RGB(255, 255, 255)
            End If
        End With
    End If
    Cancel = True
End Sub

Niels28 · 11 nov 2014

dan zo:

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Range("F:F")) Is Nothing Then
    If (Target.Row - 1) Mod 5 = 0 Then
    Target.Value = IIf(Target.Value = "R", "Q", "R")
         With Target.Offset(3, 1)
            If Target.Value = "R" Then
                .Interior.Color = RGB(255, 255, 153)
                .Font.Color = RGB(255, 0, 0)
                .Font.Name = "Arial"
                .Value = "binnen"
            Else
                .Value = ""
                .Interior.Color = RGB(255, 255, 255)
            End If
        End With
    End If
    End If
    Cancel = True
End Sub

Niels

kaan · 11 nov 2014

Dit is perfect! :thumb:

Kun je me ook aanweizingen geven hoe ik dit met kolom E kunnen doen?

Niels28 · 11 nov 2014

Ja hoor,

ga ik zo aan beginnen

Niels

Niels28 · 11 nov 2014

bij deze de complete macro

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.ScreenUpdating = False
    If Not Intersect(Target, Range("F:F")) Is Nothing Then
    
    Target.Value = IIf(Target.Value = "R", "Q", "R")
    
         With Target.Offset(3, 1)
         
            If Target.Value = "R" Then
                .Interior.Color = RGB(255, 255, 153)
                .Font.Color = RGB(255, 0, 0)
                .Font.Name = "Arial"
                .Value = "binnen"
            Else
                .Value = ""
                .Interior.Color = RGB(255, 255, 255)
            End If
            
        End With
        Cancel = True
    End If
    
    
   '=====================kolom E===========================
    
        If Not Intersect(Target, Range("E:E")) Is Nothing Then
    
    Target.Value = IIf(Target.Value = "R", "Q", "R")
    
         With Target.Offset(, -3)
        
 If Target.Value = "R" Then
 
.Resize(1, 7).Interior.Color = RGB(255, 255, 255)
.Resize(1, 5).Font.Color = RGB(217, 217, 217)
.Offset(5).Resize(1, 2).Font.Color = RGB(128, 128, 128)
.Offset(1).Resize(3, 1).EntireRow.Hidden = True

Else

.Offset(1).Resize(3, 1).EntireRow.Hidden = False

.Resize(1, 7).font.Color = RGB(0, 0, 0)
.Offset(1).Resize(3, 7).Font.Color = RGB(0, 0, 0)

    With .Resize(1, 7).Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 90
        .Gradient.ColorStops.Clear
    End With
    With .Resize(1, 7).Interior.Gradient.ColorStops.Add(0)
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.250984221930601
    End With
    With .Resize(1, 7).Interior.Gradient.ColorStops.Add(1)
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -5.09659108249153E-02
    End With

    With .Offset(, 5).Resize(1, 2).Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 90
        .Gradient.ColorStops.Clear
    End With
    With .Offset(, 5).Resize(1, 2).Interior.Gradient.ColorStops.Add(0)
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -5.09659108249153E-02
    End With
    With .Offset(, 5).Resize(1, 2).Interior.Gradient.ColorStops.Add(1)
        .Color = 6684927
        .TintAndShade = 0
    End With
    Range("A6").Activate
    End If

        End With
        Cancel = True
    End If

End Sub

Niels

kaan · 11 nov 2014

Dit gaat al helemaal de goede kant op.

Enige nadeel nu is als er ergens ander in de kolom E of F word dubbel geklikt word de module ook geactiveerd!
Hoe kan ik dit voorkomen?

Niels28 · 11 nov 2014

bij deze:

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.ScreenUpdating = False
    If Not Intersect(Target, Range("F:F")) Is Nothing Then
    If (Target.Row - 1) Mod 5 = 0 Then
    Target.Value = IIf(Target.Value = "R", "Q", "R")
    
         With Target.Offset(3, 1)
         
            If Target.Value = "R" Then
                .Interior.Color = RGB(255, 255, 153)
                .Font.Color = RGB(255, 0, 0)
                .Font.Name = "Arial"
                .Value = "binnen"
            Else
                .Value = ""
                .Interior.Color = RGB(255, 255, 255)
            End If
            
        End With
        Cancel = True
    End If
    End If
    
   '=====================kolom E===========================
    
        If Not Intersect(Target, Range("E:E")) Is Nothing Then
    If (Target.Row - 1) Mod 5 = 0 Then
    Target.Value = IIf(Target.Value = "R", "Q", "R")
    
         With Target.Offset(, -3)
        
 If Target.Value = "R" Then
 
.Resize(1, 7).Interior.Color = RGB(255, 255, 255)
.Resize(1, 5).Font.Color = RGB(217, 217, 217)
.Offset(5).Resize(1, 2).Font.Color = RGB(128, 128, 128)
.Offset(1).Resize(3, 1).EntireRow.Hidden = True

Else

.Offset(1).Resize(3, 1).EntireRow.Hidden = False

.Resize(1, 7).Font.Color = RGB(0, 0, 0)
.Offset(1).Resize(3, 7).Font.Color = RGB(0, 0, 0)

    With .Resize(1, 7).Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 90
        .Gradient.ColorStops.Clear
    End With
    With .Resize(1, 7).Interior.Gradient.ColorStops.Add(0)
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.250984221930601
    End With
    With .Resize(1, 7).Interior.Gradient.ColorStops.Add(1)
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -5.09659108249153E-02
    End With

    With .Offset(, 5).Resize(1, 2).Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 90
        .Gradient.ColorStops.Clear
    End With
    With .Offset(, 5).Resize(1, 2).Interior.Gradient.ColorStops.Add(0)
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -5.09659108249153E-02
    End With
    With .Offset(, 5).Resize(1, 2).Interior.Gradient.ColorStops.Add(1)
        .Color = 6684927
        .TintAndShade = 0
    End With
    Range("A6").Activate
    End If

        End With
        Cancel = True
    End If
    End If
End Sub

Niels

snb · 11 nov 2014

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    with Target
       if .column & (.row mod 5) ="51" then 
         .Value = IIf(.Value = "R", "Q", "R")
    
         With .Offset(3, 1)
            .Value = iif(target.value="R","binnen","")
            .Interior.Color = RGB(255, 255, 255+ 102*(.value=""))         
            .Font.Color = RGB(255*(.value=""), 0, 0)
            .Font.Name = "Arial"
        End With
      end if
    end with
    Cancel = True
End Sub

kaan · 11 nov 2014

Dit is het inderdaad, erg veel bedankt Niels.

Even een andere vraag wel in dit lijst!

Waar ik opzoek naar ben is volgende truck:

In H8 komt een tekst te staan als voorbeeld D001, waar ik opzoek naar ben is:

als in J7 t/m J9 en of M7 t/m M9 en of P7 en t/m T9 waarde dan in cel -1 waarde vanuit h8 invoeren.

Kun je me ook hiermee helpen?

kaan · 11 nov 2014

Hoi SNB,

Aller eerst bedankt dat je met me mee denkt.
Ik heb ook jouw code ook geprobeerd maar ik kreeg een error melding.

snb zei:

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    with Target
       if .column & (.row mod 5) ="51" then 
         .Value = IIf(.Value = "R", "Q", "R")
    
         With .Offset(3, 1)
            .Value = iif(target.value="R","binnen","")
            .Interior.Color = RGB(255, 255, 255+ 102*(.value=""))         
            .Font.Color = RGB(255*(.value=""), 0, 0)
            .Font.Name = "Arial"
        End With
      end if
    end with
    Cancel = True
End Sub

Niels28 · 11 nov 2014

misschien wel maar dan graag je vraag in het Nederlands, begrijp na 6x lezen nog niet wat je bedoelt.

Niels

Niels28 · 11 nov 2014

Ik wachtte al op het antwoord van snb, jammer dat het antwoord alleen over kolom F ging

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    With Target
       If .Column & ((.Row [COLOR="#FF0000"]- 1[/COLOR]) Mod 5) = "[COLOR="#FF0000"]60[/COLOR]" Then
         .Value = IIf(.Value = "R", "Q", "R")
    
         With .Offset(3, 1)
            .Value = IIf(Target.Value = "R", "binnen", "")
            .Interior.Color = RGB(255, 255, [COLOR="#FF0000"]153[/COLOR] + 102 * (.Value = ""))
            .Font.Color = RGB(255 * (.Value = ""), 0, 0) 'deze gaat nog fout
            .Font.Name = "Arial"
        End With
      End If
    End With
    Cancel = True
End Sub

Niels

snb · 11 nov 2014

iets anders
NB. in VBA is : true = -1

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    with Target
       if .column & (.row mod 5) ="51" then 
         .Value = IIf(.Value = "R", "Q", "R")
    
         With .Offset(3, 1)
            .Value = iif(target.value="R","binnen","")
            .Interior.Color = RGB(255, 255, 255+ 102*([COLOR="#FF0000"].value<>""[/COLOR]))         
            .Font.Color = RGB(255*(.value<>""), 0, 0)
            .Font.Name = "Arial"
        End With
      end if
    end with
    Cancel = True
End Sub

Niels28 · 11 nov 2014

Dan gaat hij nog mis op -255 bij de font color

ik heb mijn bericht net aangepast, staan nog een paar kleinigheidjes in.
Ben heel benieuwd naar het 2de deel (kolom E)

Niels

kaan · 11 nov 2014

HAHAHA,

Je heb helemaal gelijk

.

Ik zal me best doen om het anders te formulieren.

Als je in de bijlage kijkt zul je zien dat er op cel H8 D001 staat.
Waar ik opzoek naar ben is als ik in cel J6 t/m J9 een waarde invoeg dan dat er in cel daarvoor de waarde van cel H8 word ingevoerd en dit geld ook voor kolom M en P.

Als waarde in cel J6 dan waarde vanuit H8 in I6 invoeren

Ik hoop dat ik nu wel duidelijk ben met me vraag

Niels28 · 11 nov 2014

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Union(Range("J:J"), Range("M:M"), Range("P:P"))) Is Nothing Then  Target.Offset(, -1).Value = Cells((Target.Row - (Target.Row Mod 5)) + 3, 8).Value
End Sub

nu kom je met de vraag om de waarde weer te wissen als je de tekst wist, heb het volgende geprobeerd maar gaat dan fout als je de cel leeg maakt.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Union(Range("J:J"), Range("M:M"), Range("P:P"))) Is Nothing Then Target.Offset(, -1).Value = IIf(Target.Value = "", "", Cells((Target.Row - (Target.Row Mod 5)) + 3, 8).Value)
End Sub

ik weet niet waarom misschien dat iemand anders het ziet.

Niels

snb · 11 nov 2014

Dit heeft meer met 'kant-en-klaar oplossen in plaats van' dan met 'helpen om zelf een oplossing te maken' te maken.

kaan · 11 nov 2014

Hoi Niels,

Wederom een geniale oplossing, wat mij al maanden bezig houdt heb jij met een formule opgelost.

Over die fout melding ga ik wel afwachten met de hoop dat er misschien iemand daar een oplossing voor heeft, anders vind ik dit zo ook prima als het niet anders kan.

Ontzettend veel dank voor je hulp.
Kaan

Niels28 zei:
Code:

Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Union(Range("J:J"), Range("M:M"), Range("P:P"))) Is Nothing Then Target.Offset(, -1).Value = Cells((Target.Row - (Target.Row Mod 5)) + 3, 8).Value End Sub

nu kom je met de vraag om de waarde weer te wissen als je de tekst wist, heb het volgende geprobeerd maar gaat dan fout als je de cel leeg maakt.

Code:

Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Union(Range("J:J"), Range("M:M"), Range("P:P"))) Is Nothing Then Target.Offset(, -1).Value = IIf(Target.Value = "", "", Cells((Target.Row - (Target.Row Mod 5)) + 3, 8).Value) End Sub

ik weet niet waarom misschien dat iemand anders het ziet.

Niels

Hoe kan ik een VBA code verkorten?

Gebruiker

Bijlagen

Terugkerende gebruiker

Gebruiker

Terugkerende gebruiker

Gebruiker

Terugkerende gebruiker

Terugkerende gebruiker

Gebruiker

Terugkerende gebruiker

Verenigingslid

Gebruiker

Gebruiker

Terugkerende gebruiker

Terugkerende gebruiker

Verenigingslid

Terugkerende gebruiker

Gebruiker

Bijlagen

Terugkerende gebruiker

Verenigingslid

Gebruiker

Wij waarderen jouw privacy