Kan deze code sneller

[eyeye]

Hallo,

Ik heb weer eens een mooi code geschreven waar ik erg blij mee ben. Helaas is hij erg langzaam. Heeft iemand tips om deze code te versnellen?
De code controleert of de naam in de cel overeenkomt met een waarde op een ander tabblad en als dat zo is past hij de lay-out aan.

Sub filiaalnamen()
Dim rng As Range
Dim rng2 As Range

C = ThisWorkbook.Sheets("Dashboard").Range("B2").Value ' bovenste regels
Y = Range("I" & Rows.Count).End(xlUp).Row
antwoord = 0

Application.ScreenUpdating = False

Set rng = ThisWorkbook.Sheets("planning").Range(Cells(C, 2), Cells(Y, 8))
Set rng2 = ThisWorkbook.Sheets("Tabel").Range("D2:D16")

For Each cell In rng
        cell.Value = LCase(cell.Value): cell.Value = StrConv(cell.Value, vbProperCase)
        cell2 = cell
            For Each x In rng2
               x.Value = LCase(x.Value): x.Value = StrConv(x.Value, vbProperCase)
                If x = cell2 Then
                    antwoord = 1
                End If
            Next x
            
            If antwoord = 1 Then
                cell.Font.Bold = True
                    With cell.Interior
                        .Pattern = xlNone
                        .TintAndShade = 0
                        .PatternTintAndShade = 0
                    End With
                    With cell.Font
                        .ColorIndex = xlAutomatic
                        .TintAndShade = 0
                    End With
            End If
antwoord = 0
Next cell

MsgBox ("Klaar")

Application.ScreenUpdating = True
End Sub

Bedankt!

 

[wampier]

Je kunt calculate op manual zetten. Indien je voorwaardelijke opmaak of andere triggered macro's gebruikt kun je ook events disablen om de snelheid te verhogen

 

[eyeye]

Heeft even geduurd voordat ik het kon proberen, maar inderdaad. Deze twee opties zorgen er voor dat het een stuk sneller gaat! Bedankt.

 

[snb]

Sub M_snb()
    sn = ThisWorkbook.Sheets("planning").Cells(ThisWorkbook.Sheets("Dashboard").Range("B2").value, 2).resize(ThisWorkbook.Sheets("Dashboard").cells(rows.count,9)end(xlup).row,  8)
   sp = ThisWorkbook.Sheets("Tabel").Range("D2:D16")

   For Each it In sn
      For j=1 to ubound(sp)
        if lcase(sp(j))=lcase(it) then sp(j,1)=1
      next
    next  
          
    for j=1 to ubound(sp)
      If sp(j)= 1 Then
         with ThisWorkbook.Sheets("Tabel").cells(1,4).offset(j)
           .Font.Bold = True
           With .Interior
              .Pattern = xlNone
              .TintAndShade = 0
              .PatternTintAndShade = 0
            End With
         end with
     end if
   next
End Sub

 

[eyeye]

Hallo snb,


Ziet er goed uit. Heb de code in mijn module geplaatst. Kreeg eerst de fout melding dat regel

    sn = ThisWorkbook.Sheets("planning").Cells(ThisWorkbook.Sheets("Dashboard").Range("B2").value, 2).resize(ThisWorkbook.Sheets("Dashboard").cells(rows.count,9)end(xlup).row,  8)

Niet klopte. Dat heb ik opgelost door het plaatsten van een punt voor het woord end.

Alleen nu loopt de code vast bij:

If LCase(sp(j)) = LCase(it) Then

met de melding: Subscript out of range (Error 9)

Helaas is mijn kennis met VBA nog te beperkt om dit op te lossen. Kun je me in de goed richting helpen?

 

[snb]

dit zou al aardig kunnen helpen:

If LCase(sp(j,1)) = LCase(it) Then

 

[eyeye]

Dat zorgt er inderdaad voor dat de code werkt en snel ook, alleen doet de code niet het zelfde als mijn code.

Uw code past de cellen aan in tabblad 'Tabel' als hij een gelijke waarde vind in tabblad 'Planning'

Echter is het juist andersom de bedoeling. Dat alle cellen in de range van tabblad 'planning' gecontroleerd worden op waardes die overeenkomen in de range van tabblad 'tabel'. Als dat waar is de betreffende cellen in tabblad 'planning' worden aangepast zodat deze dik gedrukt zijn, maar ook altijd met een hoofdletter beginnen.

 

[snb]

Pas dan mijn methode aan tot jouw gewenste effekt.

 

[eyeye]

Daar zal ik inderdaad eens mee gaan puzzelen. Ik vind de ubound optie handig. Maar ben ik helaas nog niet in ervaren. Ik zal eens opzoek gaan naar wat lesstof . Bedankt voor de hulp in ieder geval.

 

[eyeye]

Hallo snb,

Ik heb nu beter onder de knie wat ubound doet. Echter krijg ik nog niet precies voor elkaar wat ik zou willen. Ik heb je code aangepast, maar krijg het alleen maar voor een kolom voor elkaar en niet voor het gehele gebied. Nu kan ik de code nog 7x herhalen zodat toch elke kolom aan de beurt komt, maar er zou toch ook een direct optie moeten zijn.

Kun je me weer verder op weghelpen?

Bedankt.

Mijn code tot nu toe:

Sub M_snb()
C = ThisWorkbook.Sheets("Dashboard").Range("B2").Value ' bovenste regels
Y = Range("I" & Rows.Count).End(xlUp).Row
sn1 = ThisWorkbook.Sheets("planning").Range(Cells(C, 2), Cells(Y, 2))
sp = ThisWorkbook.Sheets("Tabel").Range("D2:D16")

    For i = 1 To UBound(sn1)
      For J = 1 To UBound(sp)
        If LCase(sp(J, 1)) = LCase(sn1(i, 1)) Then sn1(i, 1) = 1
      Next
    Next
          
    For i = 1 To UBound(sn1)
      If sn1(i, 1) = 1 Then
               With ThisWorkbook.Sheets("Planning").Cells(C, 2).Offset(i - 1)
                .Font.Bold = True
                    With .Interior
                         .Pattern = xlNone
                         .TintAndShade = 0
                         .PatternTintAndShade = 0
                    End With
                    With .Font
                         .ColorIndex = xlAutomatic
                         .TintAndShade = 0
                    End With
                    .Value = LCase(.Value): .Value = StrConv(.Value, vbProperCase)
                End With
     End If
   Next
   MsgBox ("Klaar")
End Sub