PDA

Vollständige Version anzeigen : Markieren und Zählen bis x


ArnolPe
28.09.2016, 11:05
Hallo liebes Team,
ich benötige bitte eine Hilfe:
Ich muss anhand von Datum Punkte zusammen zählen und würde das gerne per Makro (VBA) lösen wollen.
Per Inputbox soll der User das Beginn Datum eingeben, nun soll das Makro in Spalte ab A2 (immer gleich) suchen bis das Datum oder das nächst höhere gefunden wurde. Das Datum kann durchaus später liegen als das erste Datum in der Spalte A dann dürfen auch die Punkte erst ab diesem Datum gezählt werden.
Dann die Zellen A bis D gelb hinterlegen.
Nun sollen die Punkte gezählt werden nach unten (immer Spalte D) bis 250 erreicht sind. 250 ist das Minimum. Wenn nun der Wert z.B. 249 und die nächste Zelle 257 ergibt so ist das OK es darf nur nicht unter 250 sein und er darf dann auch nicht mehr weiter zählen wenn min. 250 erreicht wurden, die letzte Zelle mit Datum sollte dann auch markiert werden (A-D) und rechts daneben in E:x soll die Summe der erreichten Punkte ab Datum rein geschrieben werden. Problem ist, dass zwar die Spalten A bis D immer gleich sind aber die Anzahl der Zeilen sehr unterschiedlich, ich muss so jeden Monat 2500 prüfen und werde irre dabei.
Anbei eine Mustertabelle.
Ich danke schon im Voraus für die Hilfe
Grüße
Peter

Fennek11
28.09.2016, 11:18
Hallo,

für EIN Datum ist das recht leicht umzusetzen, aber wie geht es dann weiter? Gibt es in der selben Tabelle mit anderen Datums-Werten erneute Prüfungen?

mfg

PS: meine Einschätzung: zu einfach = langweilig

Benutzername:
28.09.2016, 12:10
Moin Peter,

guckst Du:


Option Explicit

Sub Datenabgleich()

Application.ScreenUpdating = False

With Worksheets("All Page").Columns("A:D").Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With

Worksheets("All Page").Columns("E:E").ClearContents

Dim lastRow As Long
lastRow = Worksheets("All Page").Range("A" & Rows.Count).End(xlUp).Row

Dim startDateString As String

Dim msg As String
msg = "Startdatum im Format 'dd.mm.yyyy':"

startDateString = InputBox(prompt:=msg)

Dim startDatum As Date
startDatum = CDate(startDateString)

Dim i As Integer
For i = 2 To lastRow

If startDatum <= Worksheets("All Page").Cells(i, 1).Value Then

colorRange Worksheets("All Page").Range(Cells(i, 1), Cells(i, 4))

Dim zaehler As Integer
Dim j As Integer

For j = i To lastRow

zaehler = zaehler + Worksheets("All Page").Cells(j, 4).Value

If zaehler >= 250 Then

Worksheets("All Page").Cells(j, 5).Value = zaehler

colorRange Worksheets("All Page").Range(Cells(j, 1), Cells(j, 4))

zaehler = 0

End If

Next j

Exit For

End If

Next i

Application.ScreenUpdating = True

End Sub
Sub colorRange(rng As Range)

With rng.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With

End Sub


Gruss,
Stephan

ArnolPe
28.09.2016, 12:43
:boah: Hammer!! Tausend und ein Dank.. läuft wie Uhrwerk!

ArnolPe
30.09.2016, 09:05
Hallo Stefan,
soweit läuft alles super durch, wenn ich aber erkenne das es keine 250 Punkte gibt, so kann ich mir den REST alles sparen, das erkennt er zwar läuft aber trozdem weiter? Kannst du mir helfen wo ich hier den Fehler habe?

If startDatum <= Worksheets("All Page").Cells(i, 1).Value Then
colorRange Worksheets("All Page").Range(Cells(i, 1), Cells(i, 4))
Dim zaehler As Integer
Dim j As Integer
For j = i To lastRow
zaehler = zaehler + Worksheets("All Page").Cells(j, 4).Value
If zaehler >= 250 Then
Worksheets("All Page").Cells(j, 5).Value = zaehler
colorRange Worksheets("All Page").Range(Cells(j, 1), Cells(j, 4))
zaehler = 0
Else: msgbox "es gibt keine 250"
Exit Sub
End If
Next j
Exit For
End If
Next i
Application.ScreenUpdating = True

Vielen Dank für deine Hilfe, wenn du mal in München bist, melde dich dann gibts ein großes Bier dafür .
Peter

Benutzername:
30.09.2016, 12:12
Servus Peter,

Den zaehler kannst Du an der Stelle leider nicht hernehmen, der fängt nämlich ganz klein an und zählt dann jede Zeile nach oben bis er 250 erreicht (oder eben auch nicht).

Wieso willst Du Dir den Rest sparen? Dauert da irgendwas zu lang oder machst Du noch was zusäztlich?

Danke für das Bierangebot, mit den Münchner Bieren hab ich es aber nicht so ;)

Gruss,
Stephan

ArnolPe
30.09.2016, 12:23
Servus,
ich besorg auch ein Jever :-)..
Nun ich hab da vorher und nacher noch ein paar Prüfungen und Todos incl. Export nach PDF (läuft alles).
Wenn er nun keine 250 Punkte hat so muss man den anrufen, deshalb muss ich wissen wieviel er hat vom ersten Zähldatum bis zum ende der Liste, das kann auch bei dem rein der 250 und mehr hat das wäre egal aber bei dem unter 250 brächte ich ahlt die Summe am Ende,
Danke schönes Wochenende
Peter

Benutzername:
30.09.2016, 12:32
Servus Peter,

oki, da gäbe es nun verschiedene relativ einfache Möglichkeiten.

Man könnte z.B. gleich am Anfang einmal eine Summe bilden und checken ob diese <250 ist.

Oder man schreibt einfach immer in die letzte Zeile die Summe der Werte seit dem letzten 250er Block.

Gruss,
Stephan

ArnolPe
04.10.2016, 07:46
Hallo Stephan,
soweit so gut ja, nur ist ja das Beginndatum per Inputbox festgelegt und wenn ich "zähle" dann nimmt er ALLES mit?
Cells(Range("D9").End(xlDown).Offset(1, 0).Row, 4) = Application.WorksheetFunction.Sum(Range(Cells(6, 4), Cells(Range("D9").End(xlDown).Row, 4)))
If Sum >= 250 Then msgbox "Alles OK, die 250 Punkte wurden erreicht"
If Sum >= 250 Then msgbox "STOP, bitte prüfen 250 Punkte erreicht!!"
Kannst du mir bitte helfen wo ich hier ansetzen muss? Ich möchte also in der Letzen Zeile in D die Summe abr der "Inputbox" rein schreiben und dann eben prüfen ob 250 erreicht wurden oder nicht.
Danke
Grüße
Peter

Benutzername:
04.10.2016, 13:11
Moin Peter,

ich habe den ursprünglichen Code nun einmal angepasst.

- er zeigt immer in der letzten Zeile die Summe seit dem letzten Block
- es kommt eine Messagebox wenn insgesamt nie 250 erreicht wurden.

Wie immer bitte nochmal kurz selbst gegenprüfen. ;)

Gruss
Stephan


Option Explicit

Sub Datenabgleich()

Application.ScreenUpdating = False

With Worksheets("All Page").Columns("A:D").Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With

Worksheets("All Page").Columns("E:E").ClearContents

Dim lastRow As Long
lastRow = Worksheets("All Page").Range("A" & Rows.Count).End(xlUp).Row

Dim startDateString As String

Dim msg As String
msg = "Startdatum im Format 'dd.mm.yyyy':"

startDateString = InputBox(prompt:=msg)

Dim startDatum As Date
startDatum = CDate(startDateString)

Dim i As Integer
For i = 2 To lastRow

If startDatum <= Worksheets("All Page").Cells(i, 1).Value Then

colorRange Worksheets("All Page").Range(Cells(i, 1), Cells(i, 4))

'get total sum of all cells after date selection
Dim totalSum As Double
totalSum = Application.Sum(Worksheets("All Page").Range(Cells(i, 4), Cells(lastRow, 4)))

'mehr als 250?
If totalSum >= 250 Then

Dim zaehler As Integer
Dim j As Integer

For j = i To lastRow

zaehler = zaehler + Worksheets("All Page").Cells(j, 4).Value

If zaehler >= 250 Then

Worksheets("All Page").Cells(j, 5).Value = zaehler

colorRange Worksheets("All Page").Range(Cells(j, 1), Cells(j, 4))

zaehler = 0

End If

If j = lastRow Then
Worksheets("All Page").Cells(j, 5).Value = zaehler
colorRange Worksheets("All Page").Range(Cells(j, 1), Cells(j, 4))
End If
Next j

Exit For

'keine 250 insgesamt
Else
Worksheets("All Page").Cells(lastRow, 5).Value = totalSum
colorRange Worksheets("All Page").Range(Cells(lastRow, 1), Cells(lastRow, 4))
MsgBox "Keine 250 Punkte erreicht."
Exit For
End If
End If

Next i

Application.ScreenUpdating = True

End Sub
Sub colorRange(rng As Range)

With rng.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With

End Sub

ArnolPe
04.10.2016, 13:40
Hallo Stephan,
erst mal vielen herzlichen Dank für deine tolle Hilfe!
Schau mal die zwei Excel im Anhang an, bei weniger 250 ist alles korrekt bei mehr fängt er aber wieder zum zählen an und dann stimmt die Summe nicht und er färbt die letzte Zelle noch mit ein?
Danke Grüße

Peter

Benutzername:
04.10.2016, 13:48
Hallo Peter,

jo, so hatte ich das verstanden ;)

Wenn es insgesamt weniger als 250 seit der Datumsselektion ist, dann ist die Markierung und die Zahl ok?

Wenn es nach dem letzten >250 Block keine 250 mehr gibt was soll er dann machen? Die letzte Zeile nicht markieren?
Die Summe in der letzten Zeile ist immer die Summe seit dem letzten 250er Block.

Gruss,
Stephan

ArnolPe
04.10.2016, 14:32
Hallo Stephan,
Sorry falsch ausgedrück irgendwie..

1.) Weniger wie 250 alles Ok so wie es ist am Ende die Zahl rechts z.B. 192 und MSG Box.

2.) 250 und mehr Gesamtzahl am Ende rechts z.B. 269 ohne färbnung der letzen Zeile sonder wie gehabt nur bis 250 oder mehr erreicht wurden (dieses Datum ist der Schlüssel!) was danach kommt ist irrelevant aber die Gesamtzahl ab Inpuboxdatum muss stimmen und nicht erst ab 250 oder mehr neu zählen sondern gesamt.

Vielen Dank

Peter

Benutzername:
04.10.2016, 15:30
Servus Peter,

oki, nun hab ichs glaub ich verstanden - bin mir aber noch nicht so ganz sicher ;)

Probiere bitte mal das hier.

Gruss,
Stephan


Option Explicit

Sub Datenabgleich()

Application.ScreenUpdating = False

With Worksheets("All Page").Columns("A:D").Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With

Worksheets("All Page").Columns("E:E").ClearContents

Dim lastRow As Long
lastRow = Worksheets("All Page").Range("A" & Rows.Count).End(xlUp).Row

Dim startDateString As String

Dim msg As String
msg = "Startdatum im Format 'dd.mm.yyyy':"

startDateString = InputBox(prompt:=msg)

Dim startDatum As Date
startDatum = CDate(startDateString)

Dim i As Integer
For i = 2 To lastRow

If startDatum <= Worksheets("All Page").Cells(i, 1).Value Then

colorRange Worksheets("All Page").Range(Cells(i, 1), Cells(i, 4))

'get total sum of all cells after date selection
Dim totalSum As Double
totalSum = Application.Sum(Worksheets("All Page").Range(Cells(i, 4), Cells(lastRow, 4)))

'mehr als 250?
If totalSum >= 250 Then

Dim zaehler As Integer
Dim j As Integer

For j = i To lastRow

zaehler = zaehler + Worksheets("All Page").Cells(j, 4).Value

If zaehler >= 250 Then

Worksheets("All Page").Cells(j, 5).Value = zaehler

colorRange Worksheets("All Page").Range(Cells(j, 1), Cells(j, 4))

zaehler = 0

ElseIf j = lastRow Then

Worksheets("All Page").Cells(j, 5).Value = totalSum

End If
Next j

Exit For

'keine 250 insgesamt
Else
Worksheets("All Page").Cells(lastRow, 5).Value = totalSum
colorRange Worksheets("All Page").Range(Cells(lastRow, 1), Cells(lastRow, 4))
MsgBox "Keine 250 Punkte erreicht."
Exit For
End If
End If

Next i

Application.ScreenUpdating = True

End Sub
Sub colorRange(rng As Range)

With rng.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With

End Sub


Gruss,
Stephan

ArnolPe
04.10.2016, 15:52
Verry Good!! Das ist es, vielen herzlichen Dank!

Grüße

Peter