Een array als variant declareren(?)

Status
Niet open voor verdere reacties.
F

franzeman

Gebruiker
Lid geworden
2 sep 2006
Berichten
98
Beste VBA-ers,
In een Excel sheet wil ik grote hoeveelheden cellen in één handeling opmaken.
Dit lukt mij weliswaar met de huidige code (zie verder), maar het duurt een halve minuut op mijn pc voordat het klusje geklaard is.
Het is mij bekend, dat je in dit soort gevallen het grote bereik als variant moet declareren om gegevens van en naar het werkblad over te zetten.
Dit zou 'tig' keer sneller gaan, maar.........., het wil mij niet lukken.

Kan iemand voor mij bijgaande code verbeteren?

Groetjes van Franzeman
----------------------------------------------------------------------------------------------------
'Geef op een leeg tabblad voor de cellen A1, B1, C1, D1 en E1 resp. de waarden: a, b, c, d en e in.
'Geef vervolgens willekeurig in het bereik A2:Z2000 dezelfde letters in en start dan de volgende macro:

Sub Macro1()
'
' Macro1 Macro

Dim Cell As Range
Dim Row As Long
Dim i As Integer

Application.ScreenUpdating = False

Range("A2:Z2000").Select

'blad opmaken
For Each Cell In Selection
If Cell.Value = "" Or 0 Then
Cell.Interior.ColorIndex = xlNone
Cell.FormatConditions.Delete
Cell.Interior.Pattern = xlSolid
Cell.FormatConditions.Add Type:=xlExpression, Formula1:="=REST(RIJ();2)=0"
Cell.FormatConditions(1).Interior.ColorIndex = 34
Else 'voor de cellen A1, B1, C1, D1 en E1 voor resp. de waarden: a-b-c-d-e
If Cell.Value > 0 Then Cell.FormatConditions.Delete
If Cell.Value = Range("A1") Then Cell.Interior.ColorIndex = 14
If Cell.Value = Range("A1") Then Cell.Font.Bold = True
If Cell.Value = Range("A1") Then Cell.Font.ColorIndex = 2

If Cell.Value = Range("B1") Then Cell.Interior.ColorIndex = 5
If Cell.Value = Range("B1") Then Cell.Font.Bold = True
If Cell.Value = Range("B1") Then Cell.Font.ColorIndex = 2

If Cell.Value = Range("C1") Then Cell.Interior.ColorIndex = 46
If Cell.Value = Range("C1") Then Cell.Font.Bold = True
If Cell.Value = Range("C1") Then Cell.Font.ColorIndex = 2

If Cell.Value = Range("D1") Then Cell.Interior.ColorIndex = 12
If Cell.Value = Range("D1") Then Cell.Font.Bold = True
If Cell.Value = Range("D1") Then Cell.Font.ColorIndex = 2

If Cell.Value = Range("E1") Then Cell.Borders(xlDiagonalDown).LineStyle = xlContinuous
If Cell.Value = Range("E1") Then Cell.Borders(xlDiagonalUp).LineStyle = xlContinuous
If Cell.Value = Range("E1") Then Cell.Interior.ColorIndex = 6

End If
Next Cell

Range("A1").Select

Application.ScreenUpdating = True

End Sub
 
Dag Franzeman,

Met deze code 17 seconden:
Code: 
Sub Macro1()
  Dim Cell As Range
  
  Application.ScreenUpdating = False
  Range("A2:Z2000").Select
  For Each Cell In Selection
    If IsEmpty(Cell.Value) Then
      Cell.Interior.ColorIndex = xlNone
      Cell.FormatConditions.Delete
      Cell.Interior.Pattern = xlSolid
      Cell.FormatConditions.Add Type:=xlExpression, Formula1:="=REST(RIJ();2)=0"
      Cell.FormatConditions(1).Interior.ColorIndex = 34
    Else
      If Cell.Value > 0 Then Cell.FormatConditions.Delete
      If Cell.Value = Range("A1") Then
        Cell.Interior.ColorIndex = 14
        Cell.Font.Bold = True
        Cell.Font.ColorIndex = 2
      ElseIf Cell.Value = Range("B1") Then
        Cell.Interior.ColorIndex = 5
        Cell.Font.Bold = True
        Cell.Font.ColorIndex = 2
      ElseIf Cell.Value = Range("C1") Then
        Cell.Interior.ColorIndex = 46
        Cell.Font.Bold = True
        Cell.Font.ColorIndex = 2
      ElseIf Cell.Value = Range("D1") Then
        Cell.Interior.ColorIndex = 12
        Cell.Font.Bold = True
        Cell.Font.ColorIndex = 2
      ElseIf Cell.Value = Range("E1") Then
        Cell.Borders(xlDiagonalDown).LineStyle = xlContinuous
        Cell.Borders(xlDiagonalUp).LineStyle = xlContinuous
        Cell.Interior.ColorIndex = 6
      End If
    End If
  Next
  Range("A1").Select
  Application.ScreenUpdating = True
End Sub

GHegroet,

Axel.
 
Het gaat zo traag omdat je een grote lus maakt door 52000 cellen... :( Zulke lussen moet je proberen te vermijden.

Ik durf er veel op te verwedden dat het aardig wat sneller zal gaan als je gebruik maakt van de Autofilter en ook van SpecialCells(xlCellTypeBlanks) en SpecialCells(xlCellTypeVisible). Zie helpfiles voor dit laatste.

Je kan wel een lus gebruiken om door de kolommen te gaan, maar binnen elke lus een (aantal) autofilters en het gaat veel sneller uitgevoerd zijn.

Wigi
 
Wigi zei:
Het gaat zo traag omdat je een grote lus maakt door 52000 cellen... :( Zulke lussen moet je proberen te vermijden.

Ik durf er veel op te verwedden dat het aardig wat sneller zal gaan als je gebruik maakt van de Autofilter en ook van SpecialCells(xlCellTypeBlanks) en SpecialCells(xlCellTypeVisible). Zie helpfiles voor dit laatste.

Je kan wel een lus gebruiken om door de kolommen te gaan, maar binnen elke lus een (aantal) autofilters en het gaat veel sneller uitgevoerd zijn.

Wigi
Klik om te vergroten...

Hehe, ben nog wat bezig geweest. Dit doet het in jawel... 1 à 2 seconden! En wie nu nog niet overtuigd is van de inefficiëntie van lussen... ;)

Groeten

Wigi

Code: 
Sub Macro1()

    Dim rFoundCells As Range
    Dim rngToDo As Range
    Dim c As Range
    Dim rng1kolom As Range
    Dim i As Integer
    Dim t As Single
    
    t = Timer
    
    Set rngToDo = Range("A2:Z2")
    
    'temporary measure to "trick" the used range
    rngToDo.Offset(1999).Value = 1
    
    Application.ScreenUpdating = False

    For Each c In rngToDo
        
        Set rng1kolom = Range(c, Cells(2000, c.Column))
        
        'blank cells
        rng1kolom.AutoFilter Field:=1, Criteria1:="="
        
        With ActiveSheet.AutoFilter.Range
            On Error Resume Next
            Set rFoundCells = .Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
        End With
        
        With rFoundCells
            If Not .Cells Is Nothing Then
                .Interior.ColorIndex = xlNone
                .FormatConditions.Delete
                .Interior.Pattern = xlSolid
                .FormatConditions.Add Type:=xlExpression, Formula1:="=REST(RIJ();2)=0"
                .FormatConditions(1).Interior.ColorIndex = 34
            End If
        End With
        
        '> 0: no CF
        rng1kolom.AutoFilter Field:=1, Criteria1:=">0"
        
        With ActiveSheet.AutoFilter.Range
            On Error Resume Next
            Set rFoundCells = .Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeAllFormatConditions)
            On Error GoTo 0
        End With
        
        If Not rFoundCells.Cells Is Nothing Then rFoundCells.FormatConditions.Delete
        
        'A1 ==> D1
        For i = 1 To 4
            rng1kolom.AutoFilter Field:=1, Criteria1:=Cells(1, i).Value
            
            With ActiveSheet.AutoFilter.Range
                On Error Resume Next
                Set rFoundCells = .Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
            End With
            
            With rFoundCells
                If Not .Cells Is Nothing Then
                    .Interior.ColorIndex = Choose(i, 14, 5, 46, 12)
                    .Font.Bold = True
                    .Font.ColorIndex = 2
                End If
            End With
        Next i
        
        'E1
        rng1kolom.AutoFilter Field:=1, Criteria1:=Cells(1, 5).Value
        
        With ActiveSheet.AutoFilter.Range
            On Error Resume Next
            Set rFoundCells = .Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
        End With
        
        With rFoundCells
            If Not .Cells Is Nothing Then
                .Borders(xlDiagonalDown).LineStyle = xlContinuous
                .Borders(xlDiagonalUp).LineStyle = xlContinuous
                .Interior.ColorIndex = 6
            End If
        End With
        
        rng1kolom.AutoFilter
    
    Next c
    
    'clear temporary measure (see above)
    rngToDo.Offset(1999).Clear
    
    Range("A1").Select

    Application.ScreenUpdating = True
    
    MsgBox "Uitgevoerd in " & Round(Timer - t, 2) & " sec.", vbInformation
    
End Sub
 
Axel Hagg zei:
Dag Franzeman,

Met deze code 17 seconden:
Code: 
Sub Macro1()
  Dim Cell As Range
  
  Application.ScreenUpdating = False
  Range("A2:Z2000").Select
  For Each Cell In Selection
    If IsEmpty(Cell.Value) Then
      Cell.Interior.ColorIndex = xlNone
      Cell.FormatConditions.Delete
      Cell.Interior.Pattern = xlSolid
      Cell.FormatConditions.Add Type:=xlExpression, Formula1:="=REST(RIJ();2)=0"
      Cell.FormatConditions(1).Interior.ColorIndex = 34
    Else
      If Cell.Value > 0 Then Cell.FormatConditions.Delete
      If Cell.Value = Range("A1") Then
        Cell.Interior.ColorIndex = 14
        Cell.Font.Bold = True
        Cell.Font.ColorIndex = 2
      ElseIf Cell.Value = Range("B1") Then
        Cell.Interior.ColorIndex = 5
        Cell.Font.Bold = True
        Cell.Font.ColorIndex = 2
      ElseIf Cell.Value = Range("C1") Then
        Cell.Interior.ColorIndex = 46
        Cell.Font.Bold = True
        Cell.Font.ColorIndex = 2
      ElseIf Cell.Value = Range("D1") Then
        Cell.Interior.ColorIndex = 12
        Cell.Font.Bold = True
        Cell.Font.ColorIndex = 2
      ElseIf Cell.Value = Range("E1") Then
        Cell.Borders(xlDiagonalDown).LineStyle = xlContinuous
        Cell.Borders(xlDiagonalUp).LineStyle = xlContinuous
        Cell.Interior.ColorIndex = 6
      End If
    End If
  Next
  Range("A1").Select
  Application.ScreenUpdating = True
End Sub

GHegroet,

Axel.
Klik om te vergroten...
 
Kortere code, maar geen tijdwinst

Axel Hagg zei:
Dag Franzeman,

Met deze code 17 seconden:
Code: 
Sub Macro1()
  Dim Cell As Range
  
  Application.ScreenUpdating = False
  Range("A2:Z2000").Select
  For Each Cell In Selection
    If IsEmpty(Cell.Value) Then
      Cell.Interior.ColorIndex = xlNone
      Cell.FormatConditions.Delete
      Cell.Interior.Pattern = xlSolid
      Cell.FormatConditions.Add Type:=xlExpression, Formula1:="=REST(RIJ();2)=0"
      Cell.FormatConditions(1).Interior.ColorIndex = 34
    Else
      If Cell.Value > 0 Then Cell.FormatConditions.Delete
      If Cell.Value = Range("A1") Then
        Cell.Interior.ColorIndex = 14
        Cell.Font.Bold = True
        Cell.Font.ColorIndex = 2
      ElseIf Cell.Value = Range("B1") Then
        Cell.Interior.ColorIndex = 5
        Cell.Font.Bold = True
        Cell.Font.ColorIndex = 2
      ElseIf Cell.Value = Range("C1") Then
        Cell.Interior.ColorIndex = 46
        Cell.Font.Bold = True
        Cell.Font.ColorIndex = 2
      ElseIf Cell.Value = Range("D1") Then
        Cell.Interior.ColorIndex = 12
        Cell.Font.Bold = True
        Cell.Font.ColorIndex = 2
      ElseIf Cell.Value = Range("E1") Then
        Cell.Borders(xlDiagonalDown).LineStyle = xlContinuous
        Cell.Borders(xlDiagonalUp).LineStyle = xlContinuous
        Cell.Interior.ColorIndex = 6
      End If
    End If
  Next
  Range("A1").Select
  Application.ScreenUpdating = True
End Sub

GHegroet,

Axel.
Klik om te vergroten...

Beste Axel,

Bedankt voor je reactie. Ik heb jouw code in tijd gemeten en het levert op mijn pc een tijdwinst op van 0,4 sec. Sorry, maar daar doe ik het niet voor.
Het probleem zit 'm in het gebruik van de lus in de vba-code én het grote selectiegebied. Die lus moet UIT de code!
Wigi heeft mij inmiddels een andere oplossing aan de hand gedaan, die het weliswaar op mijn pc in 5 seconden(!) doet, maar vervolgens een psychedelisch plaatje oplevert. Daar ga ik nog even mee stoeien.

Vooralsnog bedankt,

Groetjes van Franzeman
 
Nog sneller!!!

franzeman zei:
Beste Axel,

Bedankt voor je reactie. Ik heb jouw code in tijd gemeten en het levert op mijn pc een tijdwinst op van 0,4 sec. Sorry, maar daar doe ik het niet voor.
Het probleem zit 'm in het gebruik van de lus in de vba-code én het grote selectiegebied. Die lus moet UIT de code!
Wigi heeft mij inmiddels een andere oplossing aan de hand gedaan, die het weliswaar op mijn pc in 5 seconden(!) doet, maar vervolgens een psychedelisch plaatje oplevert. Daar ga ik nog even mee stoeien.

Vooralsnog bedankt,

Groetjes van Franzeman
Klik om te vergroten...

Beste Wigi en Axel,

Ik heb de toegestuurde code (van Wigi) gebruikt, maar krijg niet het gewenste resultaat. Heb vervolgens de iets snellere code (dan van mij) van Axel overgenomen en voor de bulkopmaak een gedeelte van de code van Wigi gebruikt. Welnu: in 0,6 seconden heren!!!

In het bijgevoegde bestand bevinden zich de volgende macro's:
macro1 - Franzeman
macro2 - Axel
macro3 - Wigi
macro4 - Axel, Wigi en Franzeman

Ik meld de vraag nog niet af, omdat ik benieuwd ben naar de werkende code van Wigi.

Vriendelijk dank en groetjes van,

Franzeman
 

Bijlagen

franzeman zei:
Ik meld de vraag nog niet af, omdat ik benieuwd ben naar de werkende code van Wigi.
Klik om te vergroten...

Hier is mijn werkende code. De tijden zijn voor mij: 0,67 sec. voor de "samengestelde macro" en 0,78 sec. voor deze macro.

Het probleem lag hem in het feit dat ik de Autofilter moet terugzetten in de lus door de cellen A1:D1 telkens als de autofilter gebruikt is geweest. Dan gaat het wel goed. Zie code in het vet.

Code: 
Sub Macro3()

    Dim rFoundCells As Range
    Dim rngToDo As Range
    Dim c As Range
    Dim rng1kolom As Range
    Dim i As Integer
    Dim t As Single
    
    t = Timer
    
    Set rngToDo = Range("A2:Z2")
    
    'temporary measure to "trick" the used range
    rngToDo.Offset(1999).Value = 1
    
    Application.ScreenUpdating = False

    For Each c In rngToDo
        
        Set rng1kolom = Range(c, Cells(2000, c.Column))
        
        'blank cells
        rng1kolom.AutoFilter Field:=1, Criteria1:="="
        
        With ActiveSheet.AutoFilter.Range
            On Error Resume Next
            Set rFoundCells = .Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
        End With
        
        With rFoundCells
            If Not .Cells Is Nothing Then
                .Interior.ColorIndex = xlNone
                .FormatConditions.Delete
                .Interior.Pattern = xlSolid
                .FormatConditions.Add Type:=xlExpression, Formula1:="=REST(RIJ();2)=0"
                .FormatConditions(1).Interior.ColorIndex = 34
            End If
        End With
        
        '> 0: no CF
        rng1kolom.AutoFilter Field:=1, Criteria1:=">0"

        With ActiveSheet.AutoFilter.Range
            On Error Resume Next
            Set rFoundCells = .Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
        End With

        If Not rFoundCells.Cells Is Nothing Then rFoundCells.FormatConditions.Delete
        
        'A1 ==> D1
        For i = 1 To 4
        
            [B]rng1kolom.AutoFilter[/B]
            rng1kolom.AutoFilter Field:=1, Criteria1:=Cells(1, i).Value

            With ActiveSheet.AutoFilter.Range
                On Error Resume Next
                Set rFoundCells = .Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
            End With

            With rFoundCells
                If Not .Cells Is Nothing Then
                    .Interior.ColorIndex = Choose(i, 14, 5, 46, 12)
                    .Font.Bold = True
                    .Font.ColorIndex = 2
                End If
            End With
        Next i

        'E1
        [B]rng1kolom.AutoFilter[/B]
        rng1kolom.AutoFilter Field:=1, Criteria1:=Cells(1, 5).Value

        With ActiveSheet.AutoFilter.Range
            On Error Resume Next
            Set rFoundCells = .Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
        End With

        With rFoundCells
            If Not .Cells Is Nothing Then
                .Borders(xlDiagonalDown).LineStyle = xlContinuous
                .Borders(xlDiagonalUp).LineStyle = xlContinuous
                .Interior.ColorIndex = 6
            End If
        End With

        rng1kolom.AutoFilter
    
    Next c
    
    'clear temporary measure (see above)
    rngToDo.Offset(1999).Clear
    
    Range("A1").Select

    Application.ScreenUpdating = True
    
    MsgBox "Uitgevoerd in " & Round(Timer - t, 2) & " sec.", vbInformation
    
End Sub

Wigi
 
Wigi zei:
Hier is mijn werkende code. De tijden zijn voor mij: 0,67 sec. voor de "samengestelde macro" en 0,78 sec. voor deze macro.

Het probleem lag hem in het feit dat ik de Autofilter moet terugzetten in de lus door de cellen A1:D1 telkens als de autofilter gebruikt is geweest. Dan gaat het wel goed. Zie code in het vet.

Code: 
Sub Macro3()

    Dim rFoundCells As Range
    Dim rngToDo As Range
    Dim c As Range
    Dim rng1kolom As Range
    Dim i As Integer
    Dim t As Single
    
    t = Timer
    
    Set rngToDo = Range("A2:Z2")
    
    'temporary measure to "trick" the used range
    rngToDo.Offset(1999).Value = 1
    
    Application.ScreenUpdating = False

    For Each c In rngToDo
        
        Set rng1kolom = Range(c, Cells(2000, c.Column))
        
        'blank cells
        rng1kolom.AutoFilter Field:=1, Criteria1:="="
        
        With ActiveSheet.AutoFilter.Range
            On Error Resume Next
            Set rFoundCells = .Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
        End With
        
        With rFoundCells
            If Not .Cells Is Nothing Then
                .Interior.ColorIndex = xlNone
                .FormatConditions.Delete
                .Interior.Pattern = xlSolid
                .FormatConditions.Add Type:=xlExpression, Formula1:="=REST(RIJ();2)=0"
                .FormatConditions(1).Interior.ColorIndex = 34
            End If
        End With
        
        '> 0: no CF
        rng1kolom.AutoFilter Field:=1, Criteria1:=">0"

        With ActiveSheet.AutoFilter.Range
            On Error Resume Next
            Set rFoundCells = .Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
        End With

        If Not rFoundCells.Cells Is Nothing Then rFoundCells.FormatConditions.Delete
        
        'A1 ==> D1
        For i = 1 To 4
        
            [B]rng1kolom.AutoFilter[/B]
            rng1kolom.AutoFilter Field:=1, Criteria1:=Cells(1, i).Value

            With ActiveSheet.AutoFilter.Range
                On Error Resume Next
                Set rFoundCells = .Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
            End With

            With rFoundCells
                If Not .Cells Is Nothing Then
                    .Interior.ColorIndex = Choose(i, 14, 5, 46, 12)
                    .Font.Bold = True
                    .Font.ColorIndex = 2
                End If
            End With
        Next i

        'E1
        [B]rng1kolom.AutoFilter[/B]
        rng1kolom.AutoFilter Field:=1, Criteria1:=Cells(1, 5).Value

        With ActiveSheet.AutoFilter.Range
            On Error Resume Next
            Set rFoundCells = .Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
        End With

        With rFoundCells
            If Not .Cells Is Nothing Then
                .Borders(xlDiagonalDown).LineStyle = xlContinuous
                .Borders(xlDiagonalUp).LineStyle = xlContinuous
                .Interior.ColorIndex = 6
            End If
        End With

        rng1kolom.AutoFilter
    
    Next c
    
    'clear temporary measure (see above)
    rngToDo.Offset(1999).Clear
    
    Range("A1").Select

    Application.ScreenUpdating = True
    
    MsgBox "Uitgevoerd in " & Round(Timer - t, 2) & " sec.", vbInformation
    
End Sub

Wigi
Klik om te vergroten...

Hartelijk dank Wigi,
Hij (of zij?) werkt nu ook op mijn computer.
Bedankt voor het meedenken en ik meld de vraag nu af.

Vr. gr. van Franzeman
 
franzeman zei:
Hij (of zij?) werkt nu ook op mijn computer.
Klik om te vergroten...

HIJ - of ZIJ - gebruiken: dat hangt er wat van af.

Als het code is die aangeroepen wordt door andere code, dan gebruik je HIJ. Die code wordt plichtsgetrouw uitgevoerd.

Voor de code die veel andere procedures tegelijk aanroept, gebruik je ZIJ.

Voorts:

Is het code met veel "opmaak", dan gebruik je ZIJ en nooit HIJ.

:D

OK, flauw, maar wat wil je op een zaterdagmorgen ;)

Wigi
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan