Makro, welches durch Matrix läuft, beschleunigen

Hallo Zusammen,
Ich habe eine Matrix, welche je Artikel die Verbräuche über die letzten 26 KW enthält. Diese Werte stehen in jeder Reihe von Spalte B bis AA.
In Spalte AC ist der Mittelwert für diese Reihe aufgelistet.
Das Makro durchläuft jetzt alle Zellen in der Reihe und schaut, ob der Wert kleiner ist als der Mittelwert. Sollte dies der Fall sein hebt er den Wert auf den Mittelwert an. Wenn nicht geht er weiter. Am Ende der Matrix angekommen springt er in die nächste Reihe.
Mein Problem ist, dass das Makro ca 4000 Zeilen durchlaufen muss, wass 10-15 Minuten dauert. Kein riesen Problem, aber ich frage mich, ob es nicht auch schneller geht.
Das Makro durchläuft die Matrix von B2 bis zur vorletzten Spalte der letzten Reihe.
Mein Makro sieht bisher so aus:
Dim iPROW As Integer
Dim IPCOL As Integer
Dim irow As Integer
Dim icol As Integer
irow = 2
icol = 2
PTCOL = Range("SF1").End(xlToLeft).Column
PTROW = Range("A65000").End(xlUp).Row
Application.ScreenUpdating = False
While irow < PTROW + 2
While icol < PTCOL - 2
If Cells(irow, icol).Value < Cells(irow, PTCOL - 1).Value Then
Cells(irow, icol) = Cells(irow, PTCOL - 1).Value
End If
icol = icol + 1
Wend
icol = 2
irow = irow + 1
Wend
Application.ScreenUpdating = True
Bin für jede Hilfe Dankbar.
Gruß Nico

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub ChangeValues() Dim lRow As Long, i As Long, j As Long Dim ws As Worksheet Dim avrg As Double Set ws = ThisWorkbook.Sheets("Deine Tabelle") With ws lRow = .Cells(.Rows.Count, 1).End(xlUp).Row For i = 2 To lRow avrg = .Cells(i, 29).Value For j = 2 To 27 If .Cells(i, j).Value

Option Explicit Sub ChangeValues() Dim lRow As Long, i As Long, j As Long Dim ws As Worksheet Dim avrg As Double Dim tmp As Variant Set ws = ThisWorkbook.Sheets("Deine Tabelle") With ws lRow = .Cells(.Rows.Count, 1).End(xlUp).Row For i = 2 To lRow avrg = .Cells(i, 29).Value tmp = .Range(.Cells(i, 2), .Cells(i, 27)).Value For j = LBound(tmp) To UBound(tmp) If tmp(j)

Hallo
hier mal eine Lösung über Temporäres Blatt

Sub Mittelwert()
    On Error GoTo Fehler
    Dim iPROW As Integer
    Dim IPCOL As Integer
    Dim irow As Integer
    Dim icol As Integer
    Dim TB1, TB2, RNG1 As Range, RNG2 As Range
    
    Set TB1 = Sheets("Tabelle1")
    Set TB2 = Sheets.Add(After:=Sheets(Sheets.Count)) 'temporäres Blatt erzeugen 

    irow = 2
    icol = 2
    IPCOL = TB1.Range("SF1").End(xlToLeft).Column
    iPROW = TB1.Range("A65000").End(xlUp).Row
    
    'Bereich ermitteln 
    Set RNG1 = TB1.Cells(irow, icol).Resize(iPROW - irow + 1, IPCOL - icol + 1)
    
    'Bereich gleicher größe 
    Set RNG2 = TB2.Cells(irow, icol).Resize(RNG1.Rows.Count, RNG1.Columns.Count)
    
    Application.ScreenUpdating = False
    
    'Formel in Temporären Bereich schreiben 
    RNG2.FormulaR1C1 = _
        "=MAX(" & TB1.Name & "!RC,AVERAGE(" & TB1.Name & "!RC" & icol & ":RC" & IPCOL & "))"
    
    'Wert zurückübertragen 
    RNG1.Value = RNG2.Value
    
    'Temp. Blatt löschen 
    Application.DisplayAlerts = False
    TB2.Delete
    
    
    '*** Fehlerbehandlung 
    Err.Clear
Fehler:
    Application.DisplayAlerts = True
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear
End Sub

Verwendet wird da folgende Formel

=MAX(Tabelle1!B2;MITTELWERT(Tabelle1!$B2:$E2))

Beispiel für Werte bis Spalte E
LG UweD

Beliebteste Forumthreads (12 Monate)

Makro, welches durch Matrix läuft, beschleunigen

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread