Werte verteilen

Computer: Software & Programmierung Office Software
1

Hallo zusammen, (Excel Vers. 2007)

eine Tbl. mit Tage pro Monat Spalte A (z.B. 1 Sa, 2 So usw.). In Spalte B sollte täglich ein Wert eingetragen werden, dies kommt aber vor, dass 3 Tage nichts eingetragen wird. Am 4. Tag soll der Wert, er ist kum. auf die oberen leeren Tage linear verteil werden.
Spalte A; Spalte B

  1. Sa; 45
  2. So; 33
  3. Mo;
  4. Di;
  5. Mi; 216
    Diese diff. 138 (alle Einträge ergibt Summe 216) sollen auf die vorangegangenen leeren Tage gleichmäßig verteilt werden. Wie stell ich das am besten an?

Gruß - Wolfgang

2

Spalte A; Spalte B

  1. Sa; 45
  2. So; 33
  3. Mo;
  4. Di;
  5. Mi; 216

Diese diff. 138 (alle Einträge ergibt Summe 216) sollen auf
die vorangegangenen leeren Tage gleichmäßig verteilt werden.
Wie stell ich das am besten an?

Hallo Wolfgang,

unten Rechtsklick auf den blattnamen, dann „Code anzeigen“, dort den nacxhfolgenden Code reinkopieren, ggfs. „Oberste“ anpassen, EDitor schließen.

Anpassen bedeutet, hier in dieser Zeile:
Const Oberste As Long = 1
ggfs die 1 anzuändern auf die oberste Zeile (-nnummer) deiner Tab.

Gruß
Reinhard

Option Explicit

Private Sub Worksheet\_Change(ByVal Target As Range)
Dim Zei As Long
Const Oberste As Long = 1
If Target.Value = 0 Or Target.Value = "" Then Exit Sub
If Target.Column \> 2 Then Exit Sub
If Target.Count \> 1 Then Exit Sub
If Target.Row "" Then Exit Sub
On Error GoTo Ende
Zei = Target.Row - 1
Application.EnableEvents = False
 While Cells(Zei, 2).Value = ""
 Zei = Zei - 1
 Wend
Range("B" & Zei + 1 & ":B" & Target.Row).Value = Target.Value / Range("B" & Zei + 1 & ":B" & Target.Row).Count
Ende:
Application.EnableEvents = True
End Sub
3

Hallo Reinhard,

…dein Code passt genau wie ich es mir vorstellte.Funktionier super. Ein herzliches Danke an Dich!

Gruß - Wolfgang

4

Hallo Reinhard,

jetzt habe ich doch noch ein Problem, denn die restlichen Monateswerte stehen in den Spalten D,F,H usw. bis Dez.

Gruß - Wolfgang

5

Hallo Wolfgang,

jetzt habe ich doch noch ein Problem

ja, du hast Excel *lächel*

, denn die restlichen
Monateswerte stehen in den Spalten D,F,H usw. bis Dez.

ich hab jetzt ungetestet den Code umgeschrieben, sag Bescheid wenn er nicht klappt dann teste ich ihn.
Bei fehlerhaftem Code bitte immer markierte Codezeile und Fehlernummer, Fehlerbeschreibung angeben sofern sowas auftaucht.

Private Sub Worksheet\_Change(ByVal Target As Range)
Dim Zei As Long, Bereich As Range
Const Oberste As Long = 1
If Target.Value = 0 Or Target.Value = "" Then Exit Sub
If Target.Column \> 2 Then Exit Sub
If Target.Column Mod 2 0 Or Target.Column \> 24 Then Exit Sub
If Target.Count \> 1 Then Exit Sub
If Target.Row "" Then Exit Sub
On Error GoTo Ende
Zei = Target.Row - 1
Application.EnableEvents = False
While Cells(Zei, 2).Value = ""
 Zei = Zei - 1
Wend
Set Bereich = Range(Cells(Zei + 1, Target.Column), Cells(Target.Row, Target.Column))
Bereich.Value = Target.Value / Bereich.Count
Ende:
Application.EnableEvents = True
End Sub

Gruß
Reinhard

6

Hallo Reinhard,

vielen Dank für deine Hilfe. Der neue Code wird nur in der Spalte B ausgegeben (hier Einwandfrei). In den anderen Spalten bleibt er stumm ohne einen Fehlerhinweis auszugeben.

Gruß - Wolfgang

7

vielen Dank für deine Hilfe. Der neue Code wird nur in der
Spalte B ausgegeben (hier Einwandfrei). In den anderen Spalten
bleibt er stumm ohne einen Fehlerhinweis auszugeben.

Hallo Wolfgang,

auch der Hinweis es kommt keine Fehlerbenachrichtigung ist wichtig.
Leider bin ich grad durch Fußball abgelenkt und danach gehe ich ins Bett.
Lade mal eine Mappe hoch mit file-upload, s. FAQ:2606 wo das passiert.
Dann löse ich das wahrscheinlich sehr schnell.
Kann halt sein erst morgen ganz früh oder morgen abend.

Gruß
Reinhard

8

Hallo Franz,
habe die Datei hochgeladen. Lasse dir das Fussballspiel nicht verderben. Viel Spaß bei WM-Spiel der Damen!
http://www.file-upload.net/download-3593263/Photovol…

Gruß - Wolfgang

9

Hallo Wolfgang,

Hallo Franz,

? Beckenbauer? :smile:)

habe die Datei hochgeladen. Lasse dir das Fussballspiel nicht
verderben. Viel Spaß bei WM-Spiel der Damen!
http://www.file-upload.net/download-3593263/Photovol…

nachfolgend neuer Code. Hier eine lauffähige Mappe:

http://www.file-upload.net/download-3594170/kwPhotov…

Gruß
Reinhard

Private Sub Worksheet\_Change(ByVal Target As Range)
Dim Zei As Long, Bereich As Range
Const Oberste As Long = 3
If Target.Count \> 1 Then Exit Sub
If Target.Value = 0 Or Target.Value = "" Then Exit Sub
If Target.Column Mod 2 0 Or Target.Column \> 24 Then Exit Sub
If Target.Row "" Then Exit Sub
On Error GoTo Ende
Zei = Target.Row - 1
Application.EnableEvents = False
While Cells(Zei, Target.Column).Value = ""
 Zei = Zei - 1
Wend
Set Bereich = Range(Cells(Zei + 1, Target.Column), Cells(Target.Row, Target.Column))
Bereich.Value = Target.Value / Bereich.Count
Ende:
Application.EnableEvents = True
End Sub
10

Hallo Reinhard,

ja dass du Beckenbauers Vermögen hättest würde ich dir gönnen! Entschuldige für den Franz.
Habe den Code in meine Datei kopiert u. er läuft wie ein Glöckchen. Du hast das schon super drauf. Nochmals vielen Dank für deine Mühe.

Gruß Wolfgang