Excel bestand traag

Status
Niet open voor verdere reacties.
J

johnny1980

Gebruiker
Lid geworden
28 apr 2013
Berichten
75
Beste helpers,

Graag jullie raad/advies bij deze:

Code: 
'Kleur Via
For Each v In Range("K3:K" & Range("K300").End(xlUp).Row)
    If v = "FBN" Then
        Range("K" & v.Row).Interior.ColorIndex = 43
    ElseIf v = "FVV" Then
        Range("K" & v.Row).Interior.ColorIndex = 45
    ElseIf v = "NVT" Then
        Range("K" & v.Row).Interior.ColorIndex = xlNone
    End If
Next

' Rand


For Each r In Range("A3:A" & Range("A300").End(xlUp).Row)
    If r = Value >= 0 Then
       Range("A" & r.Row, "S" & r.Row).Borders.Weight = xlThin
        'Range("M" & r.Row, "O" & r.Row).Borders.Color = vbRed
        Range("M" & r.Row, "O" & r.Row).Borders.Weight = 3
    End If
Next

'Spoor

For Each s In Range("L3:L" & Range("L300").End(xlUp).Row)
    If s = Value >= 0 Then
    Range("L" & s.Row).Interior.ColorIndex = 36
ElseIf s = "" Then
    
    Range("L" & s.Row).Interior.ColorIndex = xlNone
End If
Next

'Opmaak vertrek

For Each c In Range("F3:F" & Range("F300").End(xlUp).Row)
    If c = "SCHAARB.-VORM. BUNDEL C" Then
        Range("F" & c.Row, "G" & c.Row).Font.ColorIndex = 5
        Range("F" & c.Row, "I" & c.Row).Font.Bold = xlMedium
        Range("A" & c.Row, "D" & c.Row).Font.ColorIndex = 5
        Range("A" & c.Row, "D" & c.Row).Font.Bold = xlMedium
        Range("H" & c.Row, "I" & c.Row).Font.ColorIndex = 5
        Range("N" & c.Row, "N" & c.Row).Font.ColorIndex = 5
        Range("R" & c.Row, "R" & c.Row).Font.ColorIndex = 5
        Range("R" & c.Row, "R" & c.Row).Font.Bold = xlMedium
   
  ElseIf c = "SCHAARB.-VORM. BUNDEL R" Then
        Range("F" & c.Row, "G" & c.Row).Font.ColorIndex = 3
        Range("F" & c.Row, "I" & c.Row).Font.Bold = xlMedium
        Range("A" & c.Row, "D" & c.Row).Font.ColorIndex = 3
        Range("A" & c.Row, "D" & c.Row).Font.Bold = xlMedium
        Range("H" & c.Row, "I" & c.Row).Font.ColorIndex = 3
        Range("N" & c.Row, "N" & c.Row).Font.ColorIndex = 3
        Range("R" & c.Row, "R" & c.Row).Font.ColorIndex = 3
        Range("R" & c.Row, "R" & c.Row).Font.Bold = xlMedium
        
  
  ElseIf c = "SCHAARB.-VORM. BUNDEL P" Then
        Range("F" & c.Row, "G" & c.Row).Font.ColorIndex = 10
        Range("F" & c.Row, "I" & c.Row).Font.Bold = xlMedium
        Range("A" & c.Row, "D" & c.Row).Font.ColorIndex = 10
        Range("A" & c.Row, "D" & c.Row).Font.Bold = xlMedium
        Range("H" & c.Row, "I" & c.Row).Font.ColorIndex = 10
        Range("N" & c.Row, "N" & c.Row).Font.ColorIndex = 10
        Range("R" & c.Row, "R" & c.Row).Font.ColorIndex = 10
        Range("R" & c.Row, "R" & c.Row).Font.Bold = xlMedium
    
   ElseIf c = "SCHAARB.-VORM. BUNDEL L" Then
        Range("F" & c.Row, "G" & c.Row).Font.ColorIndex = 3
        Range("F" & c.Row, "I" & c.Row).Font.Bold = xlMedium
        Range("A" & c.Row, "D" & c.Row).Font.ColorIndex = 3
        Range("A" & c.Row, "D" & c.Row).Font.Bold = xlMedium
        Range("H" & c.Row, "I" & c.Row).Font.ColorIndex = 3
        Range("N" & c.Row, "N" & c.Row).Font.ColorIndex = 3
        Range("R" & c.Row, "R" & c.Row).Font.ColorIndex = 3
        Range("R" & c.Row, "R" & c.Row).Font.Bold = xlMedium
    
    End If
Next

'Opmaak aankomst

For Each o In Range("G3:G" & Range("G300").End(xlUp).Row)
    If o = "SCHAARB.-VORM. BUNDEL C" Then
        Range("G" & o.Row).Font.ColorIndex = 1
        
    ElseIf o = "SCHAARB.-VORM. BUNDEL R" Then
        Range("G" & o.Row).Font.ColorIndex = 3
        
    ElseIf o = "SCHAARB.-VORM. BUNDEL P" Then
        Range("G" & o.Row).Font.ColorIndex = 10
        
    ElseIf o = "SCHAARB.-VORM. BUNDEL L" Then
        Range("G" & o.Row).Font.ColorIndex = 3
           
    End If
Next


For Each o In Range("R3:R" & Range("R300").End(xlUp).Row)
    If o = "BOOK IN" & Chr(10) & "??" Then
       Range("A" & o.Row, "R" & o.Row).Interior.ColorIndex = 20

End If
Next

Na het ingeven van deze code werkt m'n excel-bestand trager, moet ik hier iets aan toevoegen (dim as,...…. )
Is de verwijzing van de range correct?
Het werkt wel maar soms moet excel precies te lang zoeken of vergelijken,.....

Thx,
Johnny
 

Bijlagen

  • Voorbeeld.xlsm
    184,7 KB · Weergaven: 45
Laatst bewerkt:
Plaats je code tussen codetags, dit is slecht leesbaar.
Tevens is van belang te weten door welk event dit wordt getriggerd.
Beter plaats je dus een voorbeeld van je document.
 
Beste Edmoor,

Het bestand is bijgevoegd, het is hetzelfde bestand ivm mijn vraag over de userform.
Ik ben geen expert in programmeren, dus als er zware fouten inzitten don't shoot me:)

Groetjes Johnny
 
Je code wordt uitgevoerd in de Worksheet_Change.
Dat betekent dus, bij iedere wijziging in een cel.
Niet zo vreemd dan dat het traag wordt.

Bepaal wanneer welke code moet worden uitgevoerd en plaats het dan in het juiste event en met met de juiste locatiecontrole er in.
 
Laatst bewerkt:
Beste Edmoor,

Waar zou ik het anders moeten zetten dan in Worksheet_Change?
De codes zijn juist veronderstel (hoop) ik, vermits het bestand wel uitvoerd wat ik vraag.
Met locatiecontrole bedoel je dan de range?
Event, dim as...?

Zoals ik reeds zei, ik ben geen specialist...... indien je me een duwtje kan geven in de juiste richting, GRAAG!!!


Johnny
 
Misschien zo...
Code: 
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Private Sub Worksheet_Change(ByVal Target As Range)
  Select Case Target.Column
    Case 1
      If Target.Value >= "0" Then
         Target.Resize(, 19).Borders.Weight = xlThin
         Target.Offset(, 12).Resize(, 3).Borders.Weight = 3
      End If
    Case 6
      If Target.Value = "SCHAARB.-VORM. BUNDEL C" Then Y = 5
      If Target.Value = "SCHAARB.-VORM. BUNDEL R" Then Y = 3
      If Target.Value = "SCHAARB.-VORM. BUNDEL P" Then Y = 10
      If Target.Value = "SCHAARB.-VORM. BUNDEL L" Then Y = 3
         Target.Resize(, 2).Font.ColorIndex = Y
         Target.Resize(, 4).Font.Bold = xlMedium
         Target.Offset(, -5).Resize(, 4).Font.ColorIndex = Y
         Target.Offset(, -5).Resize(, 4).Font.Bold = xlMedium
         Target.Offset(, 2).Resize(, 2).Font.ColorIndex = Y
         Target.Offset(, 8).Font.ColorIndex = Y
         Target.Offset(, 12).Font.ColorIndex = Y
         Target.Offset(, 12).Font.Bold = xlMedium
    Case 7
      If Target.Value = "SCHAARB.-VORM. BUNDEL C" Then Y = 1
      If Target.Value = "SCHAARB.-VORM. BUNDEL R" Then Y = 3
      If Target.Value = "SCHAARB.-VORM. BUNDEL P" Then Y = 10
      If Target.Value = "SCHAARB.-VORM. BUNDEL L" Then Y = 3
         Target.Font.ColorIndex = Y
    Case 11
      Target.Interior.ColorIndex = IIf(Target.Value = "FBN", 43, IIf(Target.Value = "FVV", 45, xlNone))
    Case 12
      Target.Interior.ColorIndex = IIf(Target.Value >= "0", 36, xlNone)
    Case 18
       If InStr(Target.Value, "BOOK IN") Then Target.Offset(, -17).Resize(, 18).Interior.ColorIndex = 20
   End Select
End Sub
[/FONT]
 
Beste Cow en Jack,

Bovenstaande code was eerst voorzien bij de voorwaardelijke opmaak.
Het probleem is dat er in het bestand waar we mee werken dagelijks heeft wat rijen worden toegevoegd en verwijderd, na verloop van tijd stonden er voor één voorwaardelijke opmaak tientallen regels in de voorwaardelijke
opmaak voor hetzelfde. Dit omdat er veel gewerkt word met copy/paste. Na verloop van tijd werkte de voorwaardelijke opmaak niet meer naar behoren, zodoende tracht ik deze in een vba te gieten.

Alvast bedankt voor jullie reactie.
 
Jack,

Je code werkt een heel stuk sneller dan die van mij...….
Enkel wanneer ik een rij verwijder krijg ik een melding: Fout13, typen komen niet met elkaar overeen die verwijst naar volgende lijn:

Code: 
 If Target.Value >= "0" Then

(deze komt in het geel te staan bij de foutopsporing).

Alvast bedankt
Johnny
 
Laatst bewerkt:
Voeg toe:
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ws_exit

' Je Code
.....
.....
...


ws_exit:
Application.EnableEvents = True
End Sub
 
Als je een rij verwijdert dan is je target.count groter dan 1 en kan target.value niet bepaald worden.
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
If target. count = 1 then
  Select Case Target.Column
de rest
end if

Nb1. Pas svp jouw eerste bericht aan en zet de code tussen codetags. Doe dat ook in jouw andere draadje. Dat maakt het allemaal wat beter leesbaar.
Nb2. Waarom gebruik je de suggesties van @cow18 in #10 niet?
 
Laatst bewerkt:
Beste VenA,

De code staat tussen codetags, sorry voor dat, ik wist niet hoe dat moest.....

Ik vermoed dat je met #10 van cow18, voorwaardelijke opmaak bedoeld?
Met het bestand werken we met 6 verschillende personen, het gevaar om een formule, opmaak,..... (per ongeluk) te verwijderen is dus groter.
Om dat te voorkomen en om een uniforme werkwijze te bekomen wil ik alles in een vba gieten.
Ook wil ik zo veel mogelijk automatisch laten gaan om zo tijd te besparen en fouten te voorkomen.

Ik heb de oplossing van Bikerbill erin geplaatst en het werkt.

Toch ook bedankt voor jou oplossing!

Johnny
 
Is er een mogelijkheid om dubbele cellen te voorkomen/verwijderen in een ander werkblad d.m.v. vba?

De inhoud van die cellen wordt weggeschreven door volgende code:

Code: 
With Sheets("Lijsten")
    a = .Range("H" & Rows.Count).End(xlUp).Row + 1
    .Cells(a, "H").Value = cmbaanvrager.Value
    .Range("H1:H1500").Sort key1:=.Range("H1:H1500"), order1:=xlAscending, Header:=xlNo
    a = .Range("K" & Rows.Count).End(xlUp).Row + 1
    .Cells(a, "K").Value = cmbip.Value
    .Range("K1:K1500").Sort key1:=.Range("K1:K1500"), order1:=xlAscending, Header:=xlNo
End With

Kan hier een stukje code ingezet worden om te voorkomen dat er meerdere keren dezelfde inhoud wordt weggeschreven naar de kolommen?

Ik heb al geprobeerd met een module maar ik krijg het niet klaar.

Johnny
 
Laatst bewerkt:
Ja, dat kan.
Bepaal wat de sleutel van een regel is en kijk dan eerst of deze al bestaat voordat je de gegevens gaat schrijven.
 
Zoiets als dit zou kunnen
Code: 
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]    If WorksheetFunction.CountIf(zoek range, zoek waarde) = 1 Then Exit Sub
[/FONT]
 
Zoiets inderdaad.
Maar in plaats van = 1 zou ik > 0 gebruiken.
 
Kan deze opmaak ook voor een aantal rijen tegelijk?
Per rij/"enkele rit" doet hij het goed, enkel wanneer ik een periode (meerdere dagen achter elkaar) ingeef doet de opmaak het niet.
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  Select Case Target.Column
    Case 1
      If Target.Value >= "0" Then
         Target.Resize(, 19).Borders.Weight = xlThin
         Target.Offset(, 12).Resize(, 3).Borders.Weight = 3
      End If
    Case 6
      If Target.Value = "SCHAARB.-VORM. BUNDEL C" Then Y = 5
      If Target.Value = "SCHAARB.-VORM. BUNDEL R" Then Y = 3
      If Target.Value = "SCHAARB.-VORM. BUNDEL P" Then Y = 10
      If Target.Value = "SCHAARB.-VORM. BUNDEL L" Then Y = 3
         Target.Resize(, 2).Font.ColorIndex = Y
         Target.Resize(, 4).Font.Bold = xlMedium
         Target.Offset(, -5).Resize(, 4).Font.ColorIndex = Y
         Target.Offset(, -5).Resize(, 4).Font.Bold = xlMedium
         Target.Offset(, 2).Resize(, 2).Font.ColorIndex = Y
         Target.Offset(, 8).Font.ColorIndex = Y
         Target.Offset(, 12).Font.ColorIndex = Y
         Target.Offset(, 12).Font.Bold = xlMedium
    Case 7
      If Target.Value = "SCHAARB.-VORM. BUNDEL C" Then Y = 1
      If Target.Value = "SCHAARB.-VORM. BUNDEL R" Then Y = 3
      If Target.Value = "SCHAARB.-VORM. BUNDEL P" Then Y = 10
      If Target.Value = "SCHAARB.-VORM. BUNDEL L" Then Y = 3
         Target.Font.ColorIndex = Y
    Case 11
      Target.Interior.ColorIndex = IIf(Target.Value = "FBN", 43, IIf(Target.Value = "FVV", 45, xlNone))
    Case 12
      Target.Interior.ColorIndex = IIf(Target.Value >= "0", 36, xlNone)
    Case 18
       If InStr(Target.Value, "BOOK IN") Then Target.Offset(, -17).Resize(, 18).Interior.ColorIndex = 20
   End Select
End Sub

De randen doen het wel prima!

Ik heb de vorige vraag tijdelijk opgelost door een vinkje bij te plaatsen, enkel als het aangevinkt is mogen de gegevens mee in het andere werkblad weggeschreven worden.


Johnny
 
Laatst bewerkt:
De randen doe je alleen wanneer je een cel in kolom A (Target.Column = 1) wijzigt.
De andere opmaak alleen in de andere in de code opgegeven kolommen.
 
Is daar een oplossing voor Edmoor?
De opmaak zou moeten uitgevoerd worden voor alles wanneer de rij(en) wordt ingevoerd.

Johnny
 
Laatst bewerkt:
Kijk naar de suggestie in #10, dan heb je totaal geen omkijken meer naar de opmaak.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan