Procedure te groot

[Ibok]

Ik heb excel bestand waarbij ik cellen die aan een bepaalde naam voldoen wil optellen. Hierbij wordt rekening gehouden met het format van de cel (numberformat = @\* mag niet geteld worden) en tevens een kleur van een cel (geel gearceerde cellen tellen niet voor "+1" maar voor "+0,5".

Dit gaat goed met de volgende module:

  Sub HERBEREKEN_OB()

''''''''''''''
'cellen berekenen
'''''''''''''
    
    Application.ScreenUpdating = False
    Dim cell As Range

'1e range
    Dim MyCount As Long
    Dim MyCount2 As Long

Sheets("blad1").Select
Range("D5:AF173").Select
   
   For Each cell In Selection
   If cell.Value = Range("AI5") Then If cell.NumberFormat = "@" Then MyCount = MyCount + 1
   Next cell
   For Each cell In Selection
   If cell.Value = Range("AI5") Then If cell.Interior.Color = 65535 Then MyCount2 = MyCount2 + 1
   Next cell
   

Range("AK5").NumberFormat = "0.0"
Range("AK5").Value = MyCount - MyCount2 + MyCount2 / 2


'2e range
    Dim MyCount3 As Long
    Dim MyCount4 As Long
    
Sheets("blad1").Select
Range("D5:AF173").Select
   For Each cell In Selection
   If cell.Value = Range("AI6") Then If cell.NumberFormat = "@" Then MyCount3 = MyCount3 + 1
   Next cell
   For Each cell In Selection
   If cell.Value = Range("AI6") Then If cell.Interior.Color = 65535 Then MyCount4 = MyCount4 + 1
   Next cell
 
Range("AK6").NumberFormat = "0.0"
Range("AK6").Value = MyCount3 - MyCount4 + MyCount4 / 2

End Sub

Echter, de range AK5 -> AK6 loopt door tot en met range AK424.....

Dit houdt in dat ik enorm veel werk heb aan het schrijven van de module, de module enorm traag wordt, maar erger: de module niet meer werkt omdat de procedure te groot wordt

Is het mogelijk om de module in te korten? Bijvoorbeeld door de range ( "AK5" ) tot en met ( "AK424" ) variabel te maken? En dat de code automatisch de volgende range zoekt in kolom AK?

In de bijlage een opzetje, zoals het werkt bij twee regels. Het moeten er echter dus zo'n 400 worden.

Alvast bedankt voor de hulp!

Bekijk bijlage Map1helpmij.xlsm

 

[mcs51mc]

Waarom zit dit niet in dezelfde loop??

   For Each cell In Selection
   If cell.Value = Range("AI5") Then If cell.NumberFormat = "@" Then MyCount = MyCount + 1
   Next cell
   For Each cell In Selection
   If cell.Value = Range("AI5") Then If cell.Interior.Color = 65535 Then MyCount2 = MyCount2 + 1
   Next cell

Iets in het genre

For Each cell In Selection
   If cell.Value = Range("AI5") Then 
      If cell.NumberFormat = "@" Then MyCount = MyCount + 1
      If cell.Interior.Color = 65535 Then MyCount2 = MyCount2 + 1
   End If
Next cell

Eigenlijk moet dit een subroutine worden met 3 inputs: a) een range, b) waarmee moet vergeleken worden (cel AI5 in bovenstaand voorbeel) en c) de rijoffset tov een vaste cel voor het antwoord.

De caller roept die sub dan 400 keren op met telkens een andere range als input, het resultaat wordt dan weggeschreven volgens de meegegeven offset.

Indien er een logica zit in de range dan kan dat alles in één loop die 400 keren wordt doorlopen. Al bij al is dat dan minder dan 50 lijnen code

Ben ik verkeerd of is de input range altijd "Range("D5:AF173")" in jouw code

 

[Ibok]

Hallo mcs51mc,

Ja, waarom zat het niet in dezelfde loop? Eerlijk gezegd wist ik niet dat dit kon . Maar dit scheelt in ieder geval al wel wat regels!

Als het mogelijk is om de code in te perken naar 50 regels ben ik helemaal blij!

Er moet inderdaad altijd gezocht worden binnen de range: ("D5:AF173").

Hetgeen waarmee vergeleken moet worden is wel verschillend: de eerste keer naar de waarde in cel AI5, de tweede keer naar de waarde in cel AI6, de derder keer naar de waarde in cel AI7, enzovoorts tot en met de waarde in cel AI424....

Het resultaat moet altijd twee kolommen rechts (in dit geval dus kolom AK) van hetgeen waarmee vergeleken is komen.

Hoe is dit dan mogelijk? Alvast bedankt!

 

[mcs51mc]

Zoiets misschien?

Ik heb wel volgende namen gedefiniëerd in de sheet
a) rngTable verwijst naar de cellen D5 tot AF173; de tabel
b) rngCheck verwijst naar cel AI5; de eerste cel waarmee moet vergeleken worden
c) rngResult verwijst naar cel AK5; de eerste cel waar de resultaten moeten komen

Zelfs met commentaar en blanco lijnen zijn het er minder dan 50

Bekijk bijlage Map1helpmij(2).xlsm

 

[Ibok]

Dat werkt perfect :thumb:,

ik loop nu echter bij het optellen van de cellen tegen een probleem:

dblcount1 = numberformat "@" 'Dit gaat goed
dblcount2 = interior.color 65535 'Dit gaat ook goed

Wanneer een cel in de tablerange het numberformat @\* heeft, wordt deze cel niet meegeteld. Het kan echter voorkomen dat de cel EN het numberformat @\* heeft EN interior.color 65535. Als dit het geval is moeten de cellen NIET geteld worden.

Ik heb geprobeerd om de twee argumenten samen te voegen met een & teken volgens onderstaande code, maar dat werkt niet...

  If objCell.NumberFormat = "@" & objCell.Interior.color = 65535 Then dblCount2 = dblCount2 + 1

Er moet dus alleen geteld worden als de cel:
1. het numberformat "@" heeft en
2. wanneer de cel het numberformat "@" & interior.color 65535 heeft

Heb je hier misschien ook nog een oplossing voor?

 

[mcs51mc]

probeer eens met "AND" ipv "&"

 

[Ibok]

Poosje buiten de deur geweest , vandaar wat vertraging in de reactie.

Dit werkt inderdaad! Dat het soms zo simple kan zijn

Bedankt!

 

[Ibok]

De code inmiddels in gebruik, echter het uitvoeren van de code duurt erg lang. Is er een mogelijkheid om de code sneller te maken of bestaat de mogelijkheid dat als er bijvoorbeeld een minteken - in de cel staat, de berekening wordt overgeslagen en doorgegaan wordt naar de volgende cel?

Alvast bedankt!

 

[Warme bakkertje]

Sub Calculate(MyWorksheet As Worksheet, MyOffset As Long)
Dim objCell         As Range
Dim dblCount1       As Double
Dim dblCount2       As Double

    With MyWorksheet
        For Each objCell In MyWorksheet.Range("rngTable")
        If objCell < 0 Then GoTo FollowUp 'of
        'If Left(objCell, 1) = "-" Then GoTo FollowUp
           If objCell.Value = .Range("rngCheck").Offset(MyOffset, 0).Value Then
              If objCell.NumberFormat = "@" Then dblCount1 = dblCount1 + 1
              If objCell.NumberFormat = "@" And objCell.Interior.Color = 65535 Then dblCount2 = dblCount2 + 1
           End If
FollowUp:
        Next objCell
        
        .Range("rngResult").Offset(MyOffset, 0).NumberFormat = "0.0"
        .Range("rngResult").Offset(MyOffset, 0).Value = dblCount1 - dblCount2 + dblCount2 / 2
    End With
End Sub

 

[Ibok]

Dag warm bakkertje,

bedankt voor de reactie, het werkt echter niet. Het duurt zelfs langer dan eerst .

Hij blijft de cel meenemen in de berekening, want als de doelcellen leeg zijn, ( .Range("rngResult").Offset(MyOffset, 0).Value = dblCount1 - dblCount2 + dblCount2 / 2
) staat na het uitvoeren van de code het resultaat vermeld.

Heb je nog suggesties?

 

[mcs51mc]

Er is een "End If" tekort in Warme bakkertje zijn broodje, euh sorry, code
vandaar dat het niet werkt.

Je moet je wel voorstellen dat je hier minstens 828.269 vergelijkingen moet doen.
Wanneer alle cellen in de tabel gelijk zijn aan kolom AI, dan worden dat zelfs al 2.484.807 vergelijkingen, en dat vraagt een beetje tijd !
Hoe laaaaaaaaang duurt het trouwens?

Daarom nog een vergelijking invoeren met die "-" zou ik niet doen.

Probeer eens dit, opgelet ik heb dit niet gecontroleerd

Sub Calculate(MyWorksheet As Worksheet, MyOffset As Long)
Dim objCell         As Range
Dim dblCount1       As Double
Dim dblCount2       As Double
Dim dblValue        As Double

    dblValue = MyWorksheet.Range("rngCheck").Offset(MyOffset, 0).Value
    
    For Each objCell In MyWorksheet.Range("rngTable")
        With objCell
            If .Value = dblValue Then
                If .NumberFormat = "@" Then
                    dblCount1 = dblCount1 + 1
                    If .Interior.Color = 65535 Then
                        dblCount2 = dblCount2 + 1
                    End If
                End If
            End If
        End With
    Next objCell
    
    With MyWorksheet.Range("rngResult").Offset(MyOffset, 0)
        .NumberFormat = "0.0"
        .Value = dblCount1 - dblCount2 * 1.5
    End With

End Sub

Nog iets: Heb je screenupdating wel af gelegd met

Application.ScreenUpdating = False

???
Dit doe je éénmalig in de caller bij de start van de code. Wanneer alles gedaan is leg je dat terug aan.

 

[mcs51mc]

Zoals Einstein reeds wist is tijd relatief

... ...Het duurt zelfs langer dan eerst .

Hi Ibok,
Bij mij duurt het 9 seconden om een volledig ingevulde tabel (range D5 tem AF175) te vergelijken met een volledige kolom AI5 tem AI175.
Zo lang is dat nu ook weer niet, of toch???
Let wel dit is met de laatste code die ik postte.


Die Appliation.ScreenUpdating= False doet niet veel terzake
Er wordt immers niet veel naar het werkblad geschreven.

 

[Ibok]

Dag mcs51mc,

Alvast bedankt voor het meedenken!

Als ik de laatste code gebruik, loopt hij stuk op:

dblValue = MyWorksheet.range("rngCheck").Offset(MyOffset, 0).Value

en ik krijg dan de melding dat de typen niet overeen komen...

Ik had de vergelijking met "-" er juist in opgenomen, zodat de code deze berekening over zou slaan. Maar als het slechts 9 seconden duurt, maakt mij het niet uit.

Met de oude code duurde het 46sec om alles na te gaan...

 

[mcs51mc]

oops vergeten aan te passen
dblValue moet van het type STRING zijn niet DOUBLE zoals in de code staat.

 

[Ibok]

Helemaal super! Werkt als een trein! :thumb: :thumb:

Hij doet er een kleine 9 seconden over. Ik heb het argument

        .NumberFormat = "0.0"

er ook uit gehaald, was een beetje overbodig, maar in een eerdere formule nam hij de waarde niet mee, maar nu wel! Dank je wel!