VBA Code zulangsam

Hallo zusammen,
Ich habe folgenden VBA Code der aber sehr langsam ist.


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Zelle As Range
Dim a As Variant
Dim b As Variant
For Each Zelle In ActiveSheet.Range("Stunden")
a = Zelle.Offset(0, 1).Value
b = Zelle.Offset(0, 2).Value
'If a = "" Or IsNumeric(a) = False and b = "" Or IsNumeric(b) = False Then
If a = "" Or b = "" Then
Zelle.Value = ""
Else
If Zelle.Value = "" Then Zelle.Formula = "=(RC[2]-RC[1])*24"
End If
Next Zelle
End Sub

Es soll eine Formel in die Zelle geschrieben werden wenn die beiden Zellen Rechts daneben nicht leer sind.
Beispiel: auf dem "Januar" Tabellenblatt W4 = (Y4-X4)*24
So das wenn ich dort Stunden eingaben mache mir in der Ziel Zelle das Ergebnis angezeigt wird. Ich aber auch eine manuelle Eingabe machen kann. Ohne das mir die Formel durch die Eingabe verloren geht.
"Stunden" ist eine Range von W4:W26 also eine Range von 23 Zellen.
Diese Range soll aber auch ca 1000 Zellen wachsen.
Jetzt habe ich folgendes Problem das die Schleife bei den 23 Zeilen schon ziemlich langsam ist.
Ich denke das eventuell hier das Problem liegt da bei jedem klick der Code duurchlaufen wird.


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Kann mir da vielleicht jemand einen Tip geben das ich den Code nutzten kann.
mfg
Sven
https://www.herber.de/bbs/user/136560.xlsm

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_Change(ByVal Target As Range) Dim Bereich As Range Dim LZ As Long LZ = ActiveSheet.Cells(Rows.Count, 24).End(xlUp).Row + 10 'zur Sicherheit 10 Zeilen mehr seit _ letztem Eintrag Set Bereich = Range(Cells(1, 24), Cells(LZ, 25)) If Not Application.Intersect(Target, Bereich) Is Nothing Then If Cells(Target.Row, 24) "" Or Cells(Target.Row, 25) "" Then Cells(Target.Row, 23).Formula = "=(RC[2]-RC[1])*24" End If End If End Sub

=Januar!$Q$4:$Q$26;Januar!$T$4:$T$26;Januar!$W$4:$W$26;Januar!$Z$4:$Z$26;Januar!$AC$4:$AC$26;Januar!$AF$4:$AF$26;Januar!$AI$4:$AI$26;Januar!$Q$54:$Q$76;Januar!$T$54:$T$76;Januar!$W$54:$W$76;Januar!$Z$54:$Z$76;Januar!$AC$54:$AC$76;Januar!$AF$54:$AF$76;Januar!$AI$54:$AI$76;Januar!$Q$104:$Q$126;Januar!$T$104:$T$126;Januar!$W$104:$W$126;Januar!$Z$104:$Z$126;Januar!$AC$104:$AC$126;Januar!$AF$104:$AF$126;Januar!$AI$104:$AI$126;Januar!$Q$154:$Q$176;Januar!$T$154:$T$176;Januar!$W$154:$W$176;Januar!$Z$154:$Z$176;Januar!$AC$154:$AC$176;Januar!$AF$154:$AF$176;Januar!$AI$154:$AI$176;Januar!$Q$204:$Q$226;Januar!$T$204:$T$226;Januar!$W$204:$W$226;Januar!$Z$204:$Z$226;Januar!$AC$204:$AC$226;Januar!$AF$204:$AF$226;Januar!$AI$204:$AI$226;Januar!$Q$254:$Q$276;Januar!$T$254:$T$276;Januar!$W$254:$W$276;Januar!$Z$254:$Z$276;Januar!$AC$254:$AC$276;Januar!$AF$254:$AF$276;Januar!$AI$254:$AI$276

Private Sub Worksheet_Change(ByVal Target As Range) Dim zelle As Range Dim myRange As Range Set myRange = ActiveSheet.Range("Stunden") If Intersect(Target, myRange) Is Nothing Then Application.EnableEvents = False 'Von der Änderung betroffene Zelle ermitteln Set zelle = ActiveSheet.Cells(Target.Row, myRange.Item(1).Column) If Not (IsEmpty(zelle.Offset(0, 1).Value) Or IsEmpty(zelle.Offset(0, 2).Value)) _ Then zelle.Formula = "=(RC[2]-RC[1])*24" Else zelle.Formula = "" End If Application.EnableEvents = True End If End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim zelle As Range Dim myRange As Range Set myRange = ActiveSheet.Range("Stunden") If Intersect(Target, myRange) Is Nothing Then Application.EnableEvents = False For Each T_Cell In Target.Cells 'Von der Änderung betroffene Zelle ermitteln Set zelle = ActiveSheet.Cells(T_Cell.Row, myRange.Item(1).Column) If Not (IsEmpty(zelle.Offset(0, 1).Value) Or IsEmpty(zelle.Offset(0, 2).Value)) _ Then zelle.Formula = "=(RC[2]-RC[1])*24" Else zelle.Formula = "" End If Next Application.EnableEvents = True End If End Sub

hI
Einiges wurde ja schon erwähnt.
1. gehört dieser Code nicht ins SelectionChange- und auch nicht ins Change-Event, sondern sollte einem Button zugewiesen werden, damit er nur auf Anforderung ausgeführt wird und nicht permanent.
2. sollte man zellen möglichst nicht einzeln in Schleifen befüllen, sondern immer als Block, wenn sie die gleiche Formel oder Inhalt bekommen sollen.
wenn du dabei bereits gefüllte Zellen ausschließen willst, kannst du .SpeciaCells benutzen.
auch die Abfrage, ob die quellzellen schon befüllt sind, kann man in die Formel einbauen.
das wäre sowiso sinnvoll, denn dann kann die Formel schon in den Zellen stehen, bevor die Quellzellen mit Zeiten gefüllt werden (vielleicht brauchst du den Code dann ja auch nicht mehr) .
der Code würde dann so aussehen:

with range("Stunden")
if worksheefunction.countblank(.cells) > 0 then
.specialcells(xlcelltypeblanks).formular1c1 = _
"=if(Count(rc[1]:rc[2])=2,(rc[2]-rc[1])*24,"""")"
end if
end with

gruß Daniel

Private Sub CommandButton1_Click() With Range("Stunden") If WorksheetFunction.CountBlank(.Cells) > 0 Then .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = _ "=if(Count(rc[1]:rc[2])=2,(rc[2]-rc[1])*24,"""")" End If End With End Sub

Beliebteste Forumthreads (12 Monate)

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA Code zulangsam

25 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread