Hat leider etwas gedauert, ...
22.01.2015 03:40:15
Luc:-?
…Laura,
weil ich eine deutlich kompliziertere Sache erst zu einem vorläufigen Abschluss bringen wollte.
Falls das nachfolgende Pgm, das eine EreignisProzedur des QuellBlattes der zu übertragenden Daten ist und deshalb in das DokumentKlassenModul dieses Blattes gehört, deinen Vorstellungen entspricht, war's das. Ansonsten musst du dich halt nochmal melden.
Die PgmKonstanten wie BlattNamen, BereichsAdressen u.A. kannst/musst du ggf noch auf deine Verhältnisse ändern:
Rem Überträgt flfd Korrekt/Ergänz aus QBereich nach ZBereich
' ohne Berücksichtigung bereits zuvor erfolgter Übernahmen
' in EingabeReihenfolge - Löschgg wdn nicht protokolliert!
Private Sub Worksheet_Change(ByVal Target As Range)
Const adQBer$ = "E7:G106", adQKzl$ = "A6:G6", adQVsp$ = "B1:B106", _
adZBer$ = "A2:D2", naZBl$ = "Tabelle2", noVal$ = "[!Xx]", _
txZKzl$ = "Nr. Situation Beurteilung Werte", ZlVers As Long = 3
Dim aktZTabZl As Long, zKzl$(), _
zBer As Range, zBl As Worksheet
On Error Resume Next
If Target.Count > 1 Or IsEmpty(Target) Then Exit Sub
Set zBl = Me.Parent.Sheets(naZBl): If zBl Is Nothing Then Exit Sub
If Not Intersect(Target, Me.Range(adQBer)) Is Nothing Then
Set zBer = zBl.Range(adZBer): zKzl = Split(txZKzl)
If IsEmpty(zBer.Cells(1, 1)) Then
zBer.HorizontalAlignment = xlCenter
zBer.Font.Bold = True: zBer = zKzl
End If
aktZTabZl = zBer.Row + ZlVers
While Not IsEmpty(zBl.Cells(aktZTabZl, 1))
aktZTabZl = aktZTabZl + 1
Wend
With zBl.Rows(aktZTabZl)
With .Cells(1)
.HorizontalAlignment = xlCenter
.NumberFormat = "0\.": .Font.Bold = True
If aktZTabZl > zBer.Row + ZlVers Then
.Value = .Offset(-1, 0) + 1
Else: .Value = 1
End If
End With
.Cells(2) = Me.Range(adQKzl).Cells(Target.Column)
.Cells(3) = Me.Range(adQVsp).Cells(Target.Row)
If Target Like noVal Then .Cells(4) = Target
End With
End If
Set zBer = Nothing: Set zBl = Nothing
End Sub
Gruß, Luc :-?