Makro programmieren

Liebe Forumsgemeinde!

Ich benötige für meine Diplomarbeit ein Makro, kann aber kein VBA. Daher
möchte ich jemanden bitten, mir folgendes Makro zu schreiben. Auf Wunsch wird
derjenige in der Arbeit lobend erwähnt:

Das Marko hat 2 Ausprägungen:

Es gibt 2 Spalten: H ist die Datenspalte, I ist eine Kriteriumsspalte.
Es gilt: (Siehe https://www.herber.de/bbs/user/2651.xls) :

I...Wert in der Kriteriumsspalte
I-1...Wert bevor I in der Kriteriumsspalte.
1:'endlosschleife
Wenn Spaltenwert I > -20 and (I-1 < I) dann beginne in H mit der
Summenberechnung.
Wenn Spaltenwert I > +10 and (I-1 < I) dann beende in H die
Summenberechnung und weise Summe in Spalte J aus.(siehe zeile 135)
Goto1:

Es gibt also 2 Schranken. 1: Die Summenberechnung startet, wenn die untere
Schranke (-20) nach oben hin durchbrochen wird (I-1 < I).
Die Summenberechnung endet wenn die obere Schranke (+10) von unten erreicht
wird (I-1 < I)(siehe Zeile 135).

Variante2:
Siehe https://www.herber.de/bbs/user/2651.xls :

Es gibt 2 Spalten: H ist die Datenspalte, I ist eine Kriteriumsspalte.
Es gilt:
I...Wert in der Kriteriumsspalte
I-1...Wert bevor I in der Kriteriumsspalte.
1:'endlosschleife
Wenn Spaltenwert I > -20 and (I-1 < I) dann beginne in H mit der
Summenberechnung.
Wenn Spaltenwert I > +10 and (I-1 < I) dann beende in H die
Summenberechnung und weise Summe in Spalte J aus.(siehe zeile 135) goto 2.
Wenn Spaltenwert I < -20 and I-1 > I dann beende in H die Summenberechnung
und weise Summe in Spalte K aus.(zeile 390) Goto 2.

2:'endlosschleife
Wenn Spaltenwert I < -20 and I-1 > I beginne Summenbeechnung
wenn Spaltenwert I > -20 and I-1 < I beende Summenberechnung weise Summe
Spalte L zu.(zeile402)
Goto1.

Es gibt also 2 Schranken. 1: Die Summenberechnung startet, wenn die untere
Schranke (-20) nach oben hin durchbrochen wird (I-1 < I).
Die Summenberechnung endet wenn die obere Schranke (+10) von unten erreicht
wird (I-1 < I)(siehe Zeile 135) oder die untere Schranke von oben ereicht
wird(I-1 > I).
Wird die untere Schranke von oben erreicht I < -20 und (I-1 > I)wird die
Summe bis I > -20 und (i-1 < I) berechnet (die untere Schranke wird nach oben
hin durchbrochen. Goto 1:

Danke im Voraus!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Variante1() Dim SummEin As Boolean Dim Summe As Double Dim ws As Worksheet Dim zeile As Long Set ws = ThisWorkbook.Worksheets(1) ws.Range("J:L").ClearContents zeile = 7 ' Variante 1 SummEin = False Do Until IsEmpty(ws.Cells(zeile, "I")) If SummEin Then ' Summation ist eingeschaltet Summe = Summe + ws.Cells(zeile, "H") ' Endebedingung prüfen If ws.Cells(zeile, "I") > 10 And _ ws.Cells(zeile - 1, "I") < ws.Cells(zeile, "I") Then ' Ende erreicht SummEin = False ws.Cells(zeile, "L") = "Aus" ' nur Info, später entfernen ws.Cells(zeile, "J") = Summe End If Else ' Summation ist ausgeschaltet ' Anfangsbedingung prüfen If ws.Cells(zeile, "I") > -20 And _ ws.Cells(zeile - 1, "I") < ws.Cells(zeile, "I") Then ' Anfang SummEin = True Summe = ws.Cells(zeile, "H") ws.Cells(zeile, "K") = "Ein" ' nur Info, später entfernen End If End If zeile = zeile + 1 Loop End Sub

Sub Variante1() Dim SummEin As Boolean Dim Summe As Double Dim ws As Worksheet Dim zeile As Long Set ws = ThisWorkbook.Worksheets(1) ws.Range("J:L").ClearContents zeile = 7 ' Variante 1 SummEin = False Do Until IsEmpty(ws.Cells(zeile, "I")) If SummEin Then ' Summation ist eingeschaltet Summe = Summe + ws.Cells(zeile, "H") ' Endebedingung prüfen If ws.Cells(zeile, "I") > 10 And _ ws.Cells(zeile - 1, "I") < ws.Cells(zeile, "I") Then ' Ende erreicht SummEin = False ws.Cells(zeile, "L") = "Aus" ' nur Info, später entfernen ws.Cells(zeile, "J") = Summe End If Else ' Summation ist ausgeschaltet ' Anfangsbedingung prüfen If ws.Cells(zeile, "I") > -20 And _ ws.Cells(zeile - 1, "I") < ws.Cells(zeile, "I") And _ ws.Cells(zeile - 1, "I") <= -20 Then ' Anfang SummEin = True Summe = ws.Cells(zeile, "H") ws.Cells(zeile, "K") = "Ein" ' nur Info, später entfernen End If End If zeile = zeile + 1 Loop End Sub

Hallo Bongo,
die Bedingungen kann man jetzt etwas einfacher und dadurch übersichtlicher formulieren,
z.B. "I-1 < -20 < I" anstelle von "I > -20 and I-1 < I and I-1 < -20".
Die Verarbeitung lässt sich meiner Ansicht nach in zwei hintereinander ablaufenden Schleifen realisieren:


Sub Variante2()
Dim SummEin As Boolean
Dim Summe As Double
Dim ws As Worksheet
Dim zeile As Long
Set ws = ThisWorkbook.Worksheets(1)
ws.Range("J:N").ClearContents
' 1. Duchlauf (Markierung S1 in Spalte M)
zeile = 7
SummEin = False
Summe = 0
Do Until IsEmpty(ws.Cells(zeile, "I"))
If SummEin Then
' Summation ist eingeschaltet
Summe = Summe + ws.Cells(zeile, "H")
' Endebedingung prüfen
If ws.Cells(zeile - 1, "I") < 10 And 10 < ws.Cells(zeile, "I") Then
' Ende J erreicht
SummEin = False
ws.Cells(zeile, "M") = "S1 Aus J" ' nur Info, später entfernen
ws.Cells(zeile, "J") = Summe
Else
If ws.Cells(zeile, "I") < -20 And -20 < ws.Cells(zeile - 1, "I") Then
' Ende K erreicht
SummEin = False
ws.Cells(zeile, "M") = "S1 Aus K" ' nur Info, später entfernen
ws.Cells(zeile, "K") = Summe
End If
End If
Else
' Summation ist ausgeschaltet
' Anfangsbedingung prüfen
If ws.Cells(zeile - 1, "I") < -20 And -20 < ws.Cells(zeile, "I") Then
' Anfang
SummEin = True
Summe = ws.Cells(zeile, "H")
ws.Cells(zeile, "M") = "S1 Ein" ' nur Info, später entfernen
End If
End If
zeile = zeile + 1
Loop
' 2. Durchlauf (Markierung S2 in Spalte N)
zeile = 7
SummEin = False
Summe = 0
Do Until IsEmpty(ws.Cells(zeile, "I"))
If SummEin Then
' Summation ist eingeschaltet
Summe = Summe + ws.Cells(zeile, "H")
' Endebedingung prüfen
If ws.Cells(zeile - 1, "I") < -20 And -20 < ws.Cells(zeile, "I") Then
' Ende erreicht
SummEin = False
ws.Cells(zeile, "N") = "S2 Aus" ' nur Info, später entfernen
ws.Cells(zeile, "L") = Summe
End If
Else
' Summation ist ausgeschaltet
' Anfangsbedingung prüfen
If ws.Cells(zeile, "I") < -20 And -20 < ws.Cells(zeile - 1, "I") Then
' Anfang
SummEin = True
Summe = ws.Cells(zeile, "H")
ws.Cells(zeile, "N") = "S2 Ein" ' nur Info, später entfernen
End If
End If
zeile = zeile + 1
Loop
End Sub

MfG
Dieter

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread