Mijn programma optimaliseren/sneller maken

[conceal]

Hi,

De laatste tijd ben ik bezig geweest met het programmeren van een algoritme. Dit algoritme zorgt ervoor dat het berekenen van een optimale indeling geen jaren duurt en is dus al een flinke verbetering. Niettemin is het programma traag als de tabel groot is (255x255 cellen). Via een andere vraag ben ik te weten gekomen hoe ik snel een groot bereik kan kopieren. Wigi gaf me:

Sheets("Input").Range("B10", Sheets("Input").Range("B10").End(xlDown).End(xlToRight)).Copy Sheets("test").Cells(1)

Dit levert me veel tijdwinst op. Niettemin kan ik deze toepassing op meerdere manieren terug laten komen om nog meer tijdwinst te boeken. Ik heb bijvoorbeeld de volgende code om het minimum van een rij te bepalen en dit van elk element af te trekken:

Sheets("test").Select
rijen = Cells(1, 1).End(xlDown).Row
kolommen = Cells(1, 1).End(xlToRight).Column

For i = 1 To rijen
    minimum = 10000
    For j = 1 To kolommen
        minimum1 = Sheets("test").Cells(i, j)
        If minimum1 < minimum Then
            minimum = minimum1
        End If
    Next j
    
    For j = 1 To kolommen
        Sheets("test").Cells(i, j) = Sheets("test").Cells(i, j) - minimum
    Next j
Next i

Is dit met de code zoals Wigi me gaf ook sneller te doen? Ik heb via via al gehoord dat 'Application.Calculation = xlCalculationManual' het programma veel sneller maakt. In principe ben ik op zoek naar alles wat mijn programma sneller kan maken... Alvast bedankt!!!!!

Groet,
Maikel

 

[Jan van Asseldonk]

probeer dit eens

Sub Minimum()
'

rijen = Cells(1, 1).End(xlDown).Row
kolommen = Cells(1, 1).End(xlToRight).Column

letter = Chr(kolommen + 64)
gebied = Range("A1:" & letter & rijen)


    Min = WorksheetFunction.Min(gebied)
    MsgBox ("Minimum = " & Min)
    
End Sub

Hiermee krijg je een melding van de laagste waarde in het gebied,

 

[Wigi]

Verbeterde code van Jan:

Sub Minimum()
    Min = WorksheetFunction.Min(Range("A1").CurrentRegion)
    MsgBox "Minimum = " & Min
End Sub

Wigi

 

[Wigi]

Om dat mininmum af te trekken van cellen in een bereik, kan je VBA code schrijven die de analogie is van:

cel met het minimum erin, kopiëren
de andere cellen selecteren
kies: Bewerken > Plakken Speciaal... > Aftrekken

Sneller dan dat kan het niet.

Wigi

 

[conceal]

Hi Wigi,

Ik had de programmatuur nog niet aangepast omdat ik met een hoop dingen tegelijk bezig was. Maar goed, ik ben het nu aan het proberen maar echt werken doet het nog niet. Ik heb nu de code:

rijen = Sheets("test").Cells(1, 1).End(xlDown).Row
kolommen = Sheets("test").Cells(1, 1).End(xlToRight).Column

For i = 1 To rijen
    minimum = 10000
    For j = 1 To kolommen
        minimum1 = Sheets("test").Cells(i, j)
        If minimum1 < minimum Then
            minimum = minimum1
        End If
    Next j
    
    For j = 1 To kolommen
        Sheets("test").Cells(i, j) = Sheets("test").Cells(i, j) - minimum
    Next j
Next i

vervangen door:

rijen = Sheets("test").Cells(1, 1).End(xlDown).Row
For i = 1 To rijen
    With Sheets("test").Range("IV1").End(xlToLeft).Offset(i, 1)
        .Value = WorksheetFunction.Min(Sheets("test").Cells(i, 1).End(xlToRight))
        .Copy
        Sheets("test").Cells(i, 1).End(xlToRight).PasteSpecial xlValues, xlSubtract
        .ClearContents
    End With
Next i

Het programma wijzigd alleen de laatste rij in allemaal nullen, terwijl dit niet eens de kleinste waarden zijn. Bijzonder vreemd. Weet je misschien wat ik fout doe?

Groet,
Maikel

 

[Wigi]

Voilà, hier maar weer eens de oplossing.

Sub afwijkingtovminimum()
    Dim rijen As Long, i As Long, rng1Rij As Range
    Application.ScreenUpdating = False
    Sheets("test").Select
    With Cells(1).CurrentRegion
        .Copy
        .PasteSpecial xlValues
    End With
    rijen = Cells(1).End(xlDown).Row
    For i = 1 To rijen
        Set rng1Rij = Range(Cells(i, 1), Cells(i, 1).End(xlToRight))
        With rng1Rij.Cells(1).End(xlToRight).Offset(, 1)
            .Value = WorksheetFunction.Min(rng1Rij)
            .Copy
            rng1Rij.PasteSpecial , xlSubtract
            .ClearContents
        End With
    Next
    Cells(1).Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Wigi

 

[conceal]

Hi Wigi,

Wederom enorm bedankt!!! Langzaam maar zeker snap ik een beetje hoe het programmeren in z'n werk gaat. Maar toch, het zal nog wel even duren voordat ik alles aangepast heb. En als het dan klaar is, dan zal ik een nieuwe 'vraag' posten met het algoritme. Ik hoop dat deze dan naar behoren werkt en dat de echte programmeurs het dan zeggen: 'ik had het ook zo gedaan' We shall see...

Groet,
Maikel

 

[conceal]

Hi Wigi,

Oke... ik ben nu het een en ander aan het aanpassen, maar ik wil wel graag blijven begrijpen wat ik doe. Ik vraag me af wat het volgende fragment toevoegd aan de code???

With Cells(1).CurrentRegion
        .Copy
        .PasteSpecial xlValues
End With

Kun je het me uitleggen??? Alvast bedankt!
Groet,
Maikel

 

[Wigi]

Hi Wigi,

Oke... ik ben nu het een en ander aan het aanpassen, maar ik wil wel graag blijven begrijpen wat ik doe. Ik vraag me af wat het volgende fragment toevoegd aan de code???

With Cells(1).CurrentRegion
        .Copy
        .PasteSpecial xlValues
End With

Kun je het me uitleggen??? Alvast bedankt!
Groet,
Maikel

RTFM