Dynamische Einträge

[Artem Gojdenko]

Hallo zusammen,

für folgendes Problem suche ich nach einer Lösung und komme nicht wirklich weiter mit Excel. Die SuFu hatte ich auch schon genutzt, jedoch nicht wirklich weitergekommen. Daher denke ich, dass da wahrscheinlich Excel mit Verbindung mit VBA her müsste.

Spalte A: 1. Januar bis 31. Dezember - Bezeichnungen für die Tage // also 365 Einträge
Spalte B: Formel: 20-C-D-E-F (fortlaufende Variable je Spalte), ebenfalls 365 Einträge // Hier soll eingesehen werden, ob an bestimmten Tagen eine bestimmte Anzahl von Items zur Verfügung hat
Spalte C,D,E,F: Standardmäßig auf 0 gesetzt, ebenfalls 365 Einträge pro Spalte// Hier soll der Nutzer an einem bestimmten Tag, die gewünschte Anzahl an Items eintragen können. 

Und jetzt mein Problem: nach dem der User zB an einem beliebigen Tag seinen Eintrag in Spalte C,D,E,F durchgeführt hat, sollen alle SECHS darüberliegenden UND darunterliegenden Zellen den eingetragenen Wert übertragen bekommen.

Mit gewöhnlichen Excel-Funktionen scheint dieses Problem nicht so einfach gelöst werden zu können, meiner Einschätzung nach. Dachte zuerst an Wenn-Dann oder Übernehmen-Funktion, aber die sind da zu statisch.

Danke für die Unterstützung schon mal. Meine Datei ist im Anhang

[Klaus-Dieter]

Hallo,

das wird nur mit VBA funktionieren.

[BigJane]

Hi,

der einfache VBA Code würde so lauten (Change Event im Worksheet, nicht im Modul). Allerdings stelle ich mir noch Fragen - was ist z.B. wenn eine zu überschreibende Zelle schon einen Eintrag enthält, also meintet wegen eine 4 drin steht und ein anderer Eintrag eine 6 erzeugen will? Ich vermute einfach dass in der Anwendung noch weitere Bedingungen dazukommen, z.B. wenn es ums Löschen oder korrigieren geht weil die verfügbare Menge von 20 überschritten wurde oder so. Es wäre also schön gleich alle möglichen Fälle zu formulieren bevor wir hier zig Runden drehen.

Ich war auch überrascht, dass du von 365 Einträgen sprichst und die Zeilen dann doch bei 255 enden weil die Wochenenden nicht enthalten sind.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

'abbrechen wenn nicht im Zielbereich oder mehr als eine Zelle
If Intersect(Target, Range("C3:F255")) Is Nothing Or Target.Count > 1 Then Exit Sub

'Zeile prüfen
Dim i As Integer
i = 9 - Target.Row
If i < 0 Then i = 0

'ausfüllen
Target.Offset(-6 + i, 0).Resize(13 - i, 1).Value = Target.Value

End Sub

[Egon12]

Hallo,

ins Modul des Tabellenblattes (Tabelle1):

Code:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i&
    Application.EnableEvents = False
    On Error GoTo Fehler
    If Not Intersect(Target, Range("C3:F255")) Is Nothing Then
        For i = -6 To 6
            If i <> 0 And Cells(Target.Row + i, 2) = 0 Then MsgBox "Geht nicht, da überlappender Eintrag ensteht": Application.EnableEvents = True: Exit Sub
        Next i
        If Target.Row < 9 Then MsgBox "Eintrag nicht möglich, da weniger als 6 freie Einträge davor vorhanden sind": Application.EnableEvents = True: Exit Sub
        If Cells(Target.Row, 2) = 0 Then
            Range("C" & Target.Row & ":F" & Target.Row).Copy
            Range("C" & Target.Row - 6 & ":F" & Target.Row + 6).PasteSpecial Paste:=xlPasteValues
        End If
    End If
    Application.EnableEvents = True
Exit Sub
Fehler:
    MsgBox "Eintrag nicht möglich, da weniger als 6 freie Einträge davor vorhanden sind"
    Application.EnableEvents = True
End Sub

  Verfügbarkeit 1.xlsm (Größe: 29,1 KB / Downloads: 3)

Gruß Uwe

[snb]

Reicht schon:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("C3:F255")) Is Nothing And Target.Count = 1 Then Target.Offset(, -Target.Column + 3).Resize(, 4) = Target
End Sub

Und: lösche alle verbundene Zellen !!!

[BigJane]

Reicht schon:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("C3:F255")) Is Nothing And Target.Count = 1 Then Target.Offset(, -Target.Column + 3).Resize(, 4) = Target
End Sub

Und: lösche alle verbundene Zellen !!!

Die 4 Zellen der Zeile auszufüllen war aber nicht die Anforderung --> also reicht nicht!

[snb]

No big deal

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("C3:F255")) Is Nothing And Target.Count = 1 Then Target.Offset(Application.Max(3 - Target.Row, -6)).Resize(7 + Application.Min(Target.Row - 3, 6)) = Target
End Sub

[Artem Gojdenko]

danke euch vielmals!