Live-Forum - Die aktuellen Beiträge
Datum
Titel
19.04.2024 13:49:38
Per Kopfdruck als pdf speichern und Mail erstellen
19.04.2024 12:58:59
Daten einfügen aus anderem Sheet
19.04.2024 12:23:24
Wenn-Formel anpassen
19.04.2024 12:09:19
Unique (Application.WorksheetFunction.Unique)
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1412to1416
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1412to1416
1412to1416
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Code mit Schleife kürzen

Code mit Schleife kürzen
03.03.2015 09:00:22
Sascha
Hallo Experten,
Ich brauche nochmals Eure Hilfe.
Excel hat mit meinem Code ziemlich lange um zu berechnen.
Ich glaube dass es daran liegt, dass mein Code so lange ist.
Wahrscheinlich müsste ich diesen Code mit einer Schleife(?) kürzen.
Leider habe ich keine Ahnung wie man das macht.
Kann mir jemand helfen?
Hier mein Code: 
Sub Vanessa_Teilnehmerzählen() 'in Kostenkontrolle ab Zelle N10 eintragen
Dim Anzahl As Long
Dim zelle As Range
Anzahl = 0
For Each zelle In Sheets("Abonnemente").Range("C16:M500")
If zelle.Interior.Color = Sheets("Abonnemente").Range("J3").Interior.Color Then
If Year(zelle) = Sheets("Kostenkontrolle").Range("C2") And Month(zelle) = 1 Then
Anzahl = Anzahl + 1
End If
End If
Next zelle
Sheets("Kostenkontrolle").Range("N10").Value = Anzahl
Anzahl = 0
For Each zelle In Sheets("Abonnemente").Range("C16:M500")
If zelle.Interior.Color = Sheets("Abonnemente").Range("J3").Interior.Color Then
If Year(zelle) = Sheets("Kostenkontrolle").Range("C2") And Month(zelle) = 2 Then
Anzahl = Anzahl + 1
End If
End If
Next zelle
Sheets("Kostenkontrolle").Range("O10").Value = Anzahl
Anzahl = 0
For Each zelle In Sheets("Abonnemente").Range("C16:M500")
If zelle.Interior.Color = Sheets("Abonnemente").Range("J3").Interior.Color Then
If Year(zelle) = Sheets("Kostenkontrolle").Range("C2") And Month(zelle) = 3 Then
Anzahl = Anzahl + 1
End If
End If
Next zelle
Sheets("Kostenkontrolle").Range("P10").Value = Anzahl
Anzahl = 0
For Each zelle In Sheets("Abonnemente").Range("C16:M500")
If zelle.Interior.Color = Sheets("Abonnemente").Range("J3").Interior.Color Then
If Year(zelle) = Sheets("Kostenkontrolle").Range("C2") And Month(zelle) = 4 Then
Anzahl = Anzahl + 1
End If
End If
Next zelle
Sheets("Kostenkontrolle").Range("Q10").Value = Anzahl
Anzahl = 0
For Each zelle In Sheets("Abonnemente").Range("C16:M500")
If zelle.Interior.Color = Sheets("Abonnemente").Range("J3").Interior.Color Then
If Year(zelle) = Sheets("Kostenkontrolle").Range("C2") And Month(zelle) = 5 Then
Anzahl = Anzahl + 1
End If
End If
Next zelle
Sheets("Kostenkontrolle").Range("R10").Value = Anzahl
Anzahl = 0
For Each zelle In Sheets("Abonnemente").Range("C16:M500")
If zelle.Interior.Color = Sheets("Abonnemente").Range("J3").Interior.Color Then
If Year(zelle) = Sheets("Kostenkontrolle").Range("C2") And Month(zelle) = 6 Then
Anzahl = Anzahl + 1
End If
End If
Next zelle
Sheets("Kostenkontrolle").Range("S10").Value = Anzahl
Anzahl = 0
For Each zelle In Sheets("Abonnemente").Range("C16:M500")
If zelle.Interior.Color = Sheets("Abonnemente").Range("J3").Interior.Color Then
If Year(zelle) = Sheets("Kostenkontrolle").Range("C2") And Month(zelle) = 7 Then
Anzahl = Anzahl + 1
End If
End If
Next zelle
Sheets("Kostenkontrolle").Range("T10").Value = Anzahl
Anzahl = 0
For Each zelle In Sheets("Abonnemente").Range("C16:M500")
If zelle.Interior.Color = Sheets("Abonnemente").Range("J3").Interior.Color Then
If Year(zelle) = Sheets("Kostenkontrolle").Range("C2") And Month(zelle) = 8 Then
Anzahl = Anzahl + 1
End If
End If
Next zelle
Sheets("Kostenkontrolle").Range("U10").Value = Anzahl
Anzahl = 0
For Each zelle In Sheets("Abonnemente").Range("C16:M500")
If zelle.Interior.Color = Sheets("Abonnemente").Range("J3").Interior.Color Then
If Year(zelle) = Sheets("Kostenkontrolle").Range("C2") And Month(zelle) = 9 Then
Anzahl = Anzahl + 1
End If
End If
Next zelle
Sheets("Kostenkontrolle").Range("V10").Value = Anzahl
Anzahl = 0
For Each zelle In Sheets("Abonnemente").Range("C16:M500")
If zelle.Interior.Color = Sheets("Abonnemente").Range("J3").Interior.Color Then
If Year(zelle) = Sheets("Kostenkontrolle").Range("C2") And Month(zelle) = 10 Then
Anzahl = Anzahl + 1
End If
End If
Next zelle
Sheets("Kostenkontrolle").Range("W10").Value = Anzahl
Anzahl = 0
For Each zelle In Sheets("Abonnemente").Range("C16:M500")
If zelle.Interior.Color = Sheets("Abonnemente").Range("J3").Interior.Color Then
If Year(zelle) = Sheets("Kostenkontrolle").Range("C2") And Month(zelle) = 11 Then
Anzahl = Anzahl + 1
End If
End If
Next zelle
Sheets("Kostenkontrolle").Range("X10").Value = Anzahl
Anzahl = 0
For Each zelle In Sheets("Abonnemente").Range("C16:M500")
If zelle.Interior.Color = Sheets("Abonnemente").Range("J3").Interior.Color Then
If Year(zelle) = Sheets("Kostenkontrolle").Range("C2") And Month(zelle) = 12 Then
Anzahl = Anzahl + 1
End If
End If
Next zelle
Sheets("Kostenkontrolle").Range("Y10").Value = Anzahl
End Sub

Liebe Grüsse
Sascha

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Code mit Schleife kürzen
03.03.2015 09:13:57
Rudi
Hallo, 
Sub Vanessa_Teilnehmerzählen() 'in Kostenkontrolle ab Zelle N10 eintragen
Dim Anzahl As Long
Dim zelle As Range
Dim i As Integer
For i = 1 To 12
Anzahl = 0
For Each zelle In Sheets("Abonnemente").Range("C16:M500")
If zelle.Interior.Color = Sheets("Abonnemente").Range("J3").Interior.Color Then
If Year(zelle) = Sheets("Kostenkontrolle").Range("C2") And Month(zelle) = i Then
Anzahl = Anzahl + 1
End If
End If
Next zelle
Sheets("Kostenkontrolle").Cells(10, i + 13) = Anzahl
Next i
End Sub
schneller wird das aber nicht
Gruß
Rudi

Anzeige
AW: Code mit Schleife kürzen
03.03.2015 10:14:25
Sascha
Hallo Rudi,
Stimmt... es wird nicht schneller, aber der Code sieht nun um ein mehrfaches besser und kompakter aus. Auch das hilft mir bei der Übersicht extrem.
Vielen Dank dafür
Gruss Sascha

AW: Code mit Schleife kürzen
03.03.2015 09:56:47
fcs
Hallo Sascha,
nachfolgend eine kürzere und wahrscheinlich schnelle Fassung.
1. Die Vergleichswerte für Jahr und Farbe werden in einer Variablen gespeichert.
So muss nur einmal auf den Zellinhalt, den Formatwert zugegriffen werden und nicht bei jedem Zellvergleich.
2. Die Zellen werden nur einmal in einer Schleife geprüft und die Zählerwerte in einem Datenarray gesammelt.
3. Typische Makrobremsen werden während der Makroausführung deaktiviert.
4. Es wird zuerst der Jahreswert verglichen, erst bei Treffer dann die Zellfarbe
Den Wert abgreifen dürfte schneller gehen als die Farbinformation auszulesen. (nur Vermutung)
Gruß
Franz 
Sub Vanessa_Teilnehmerzählen_Neu() 'in Kostenkontrolle ab Zelle N10 eintragen
Dim Anzahl(1 To 12) As Long
Dim zelle As Range
Dim lngFarbe As Long, lngJahr As Long, intMonat As Integer
Dim StatusCalc As Long
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.EnableEvents = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
lngFarbe = Sheets("Abonnemente").Range("J3").Interior.Color 'Vergleichsfarbe
lngJahr = Sheets("Kostenkontrolle").Range("C2").Value       'Vergleichs-Jahr
For Each zelle In Sheets("Abonnemente").Range("C16:M500")
If Year(zelle) = lngJahr Then
If zelle.Interior.Color = lngFarbe Then
intMonat = 0
Select Case Month(zelle)
Case 1: intMonat = 1
Case 2:  intMonat = 2
Case 3:  intMonat = 3
Case 4:  intMonat = 4
Case 5:  intMonat = 5
Case 6:  intMonat = 6
Case 7:  intMonat = 7
Case 8:  intMonat = 8
Case 9:  intMonat = 9
Case 10:  intMonat = 10
Case 11:  intMonat = 11
Case 12:  intMonat = 12
End Select
If intMonat  0 Then Anzahl(intMonat) = Anzahl(intMonat) + 1
End If
End If
Next zelle
'Zellen N10:Y10 ausfüllen
With Sheets("Kostenkontrolle").Range("N10")
For intMonat = 1 To 12
.Offset(0, intMonat - 1).Value = Anzahl(intMonat)
Next
End With
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = StatusCalc
End With
End Sub

Anzeige
AW: Code mit Schleife kürzen
03.03.2015 10:15:25
Sascha
Hallo Franz,
WOW! So funktioniert es extrem schnell. Ich bemerke die Berechnung gar nicht mehr! :-))
Super Sache.
Vielen lieben Dank für Deine Bemühung...
Liebe Grüsse
Sascha

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige