Sheet beobachten und Änderung Übertragen

22/01/2010 - 18:58 von RogHB346 | Report spam
Hallo Newsgroup
ich brauche wieder einmal Eure Hilfe

Ich Arbeite gerademal wieder an meinem Übungsobjekt und komme nicht weiter.

Ich habe einen Kalender erstellt, über 12 Sheets (Jan - Dez)
A=Tage (TT)
B=Wochentag usw.
von E bis J je ein = 1. Mitarbeiter
hier wird per VBA die Arbeitszeit (Text Zelle "08:00 - 18:00" ) eingetragen
wenn bereits bei der Erstellung des Kalender per VBA Urlaub in den
Stammdaten eingetragen ist wird dieser ebenfalls eingetragen ( "U" ).

Ist dieser Kalender per VBA erstellt und wird nun nachtràglich in den
Stammdaten ein neuer Urlaubstermin eingetragen, möchte ich diesen
Automatisch in den Kalender eintragen.

Mein Versuch mit dem an hàngenden Code, habe ich so weit das er das
Startdatum
in Spalte A beim richtigen Datum ein "U" eintràgt. Aber dann ... ?

Private Sub Worksheet_Change(ByVal Target As Range)

Dim VX1 As Variant
On Error GoTo Fehler
'
'Urlaub prüfen
Worksheets("Stammdaten").Select
'1
If Not Application.Intersect(Target, Range("D31:E40")) Is Nothing Then
U1 = 1
Set VX1 = Range("D31:E40")
End If
'2
If Not Application.Intersect(Target, Range("M31:N40")) Is Nothing Then
U2 = 1
MsgBox "Im Bereich M31:N40 wurde eine Zelle geàndert!" & U2
End If
'3
If Not Application.Intersect(Target, Range("V31:W40")) Is Nothing Then
U3 = 1
MsgBox "Im Bereich V31:W40 wurde eine Zelle geàndert!" & U3
End If
'4
If Not Application.Intersect(Target, Range("D68:E77")) Is Nothing Then
U4 = 1
MsgBox "Im Bereich D68:E77 wurde eine Zelle geàndert! " & U4
End If
'5
If Not Application.Intersect(Target, Range("M68:N77")) Is Nothing Then
U5 = 1
MsgBox "Im Bereich M68:N77 wurde eine Zelle geàndert! " & U5
End If
'6
If Not Application.Intersect(Target, Range("V68:W77")) Is Nothing Then
U6 = 1
MsgBox "Im Bereich V68:W77 wurde eine Zelle geàndert! " & U6
End If
'
With Worksheets("Jan").Range("A4:A34")
Set c = .Find(VX1(2, 1), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Value = "U"
Set c = .FindNext(c)
Loop While Not c Is Nothing 'And c.Address <> firstAddress
End If
End With
Exit Sub

Fehler:
MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
& "Beschreibung: " & Err.Description _
, vbCritical, "Fehler"

End Sub

Frage: Wer kann mir diesen Code richten
Ich bedanke mich jetzt schon einmal
MfG - Heinz
Anfànger in Excel (VBA Progm.) bitte um Verstàndnis für Dummi´s Fragen
(Excel 2007)
 

Lesen sie die antworten

#1 Andreas Killer
23/01/2010 - 11:39 | Warnen spam
RogHB346 schrieb:

Ich habe einen Kalender erstellt, über 12 Sheets (Jan - Dez)
A=Tage (TT)
B=Wochentag usw.
von E bis J je ein = 1. Mitarbeiter
hier wird per VBA die Arbeitszeit (Text Zelle "08:00 - 18:00" ) eingetragen
wenn bereits bei der Erstellung des Kalender per VBA Urlaub in den
Stammdaten eingetragen ist wird dieser ebenfalls eingetragen ( "U" ).


Hmm, kann ich mir nicht so recht vorstellen...

Ist dieser Kalender per VBA erstellt und wird nun nachtràglich in den
Stammdaten ein neuer Urlaubstermin eingetragen, möchte ich diesen
Automatisch in den Kalender eintragen.


Naja, da kannst Du doch die gleiche Methode wie bei der Erstellung
verwenden!?!

Mein Versuch mit dem an hàngenden Code, habe ich so weit das er das
Startdatum
in Spalte A beim richtigen Datum ein "U" eintràgt. Aber dann ... ?


Nun ja, ich weiß nicht so richtig was Du eigentlich möchtest und aus
dem Code werde ich auch nicht so recht schlau... aber zumindest làßt
er sich deutlich vereinfachen.

Private Sub Worksheet_Change(ByVal Target As Range)


...
Worksheets("Stammdaten").Select
'1
If Not Application.Intersect(Target, Range("D31:E40")) Is Nothing Then


Stopp! Wozu das Select? Das geht nicht! Range's die sich auf
verschiedenen Blàttern befinden liefern nie eine Schnittmenge!

Wenn dieser Code sich nicht in Sheets("Stammdaten") befindet kannst Du
das alles vergessen.

If Not Application.Intersect(Target, Range("M31:N40")) Is Nothing Then
If Not Application.Intersect(Target, Range("V31:W40")) Is Nothing Then
If Not Application.Intersect(Target, Range("D68:E77")) Is Nothing Then


Diese ganzen "If Not Application.Intersect" lassen sich gut
zusammenfassen.

With Worksheets("Jan").Range("A4:A34")
Set c = .Find(VX1(2, 1), LookIn:=xlValues)


Aus diesem Find werde ich nicht schlau, weil ich schon nicht verstehe
wieso Du nach VX1(2,1) in Sheets("Jan") suchst.

Der Urlaub könnte doch auch in einem anderen Monat liegen oder?
Oder ist Dein Problem anhand des Datums das richtige Sheet zu bestimmen?

Was jedoch eindeutig fehlt ist der Parameter "LookAt:=xlWhole", sonst
könnte Find auch nach einem Teil einer Zelle suchen.

Set c = .FindNext(c)
Loop While Not c Is Nothing 'And c.Address <> firstAddress


Dieser Part ist aus der Hilfe und den "And"-Part hast Du
auskommentiert weil Du einen Fehler bekommst, richtig?

Leider ist es eine der unangenehmen Erscheinungen von VBA das boolsche
Ausdrücke immer komplett interpretiert werden, auch wenn der erste
Part schon False ist und damit das Gesamtergebnis nie mehr True werden
kann. Sowas musst Du auftrennen.

Andreas.

Option Explicit

Private Function IntersectRange( _
This As Range, Others()) As Integer
'Prüft ob This sich mit einem Range in Others schneidet, _
gibt den Index zurück. LBound(Others)-1 für keinen.
Dim I As Integer
'Durchlaufe alle Parameter
For I = LBound(Others) To UBound(Others)
'Ist es ein Range?
If TypeOf Others(I) Is Range Then
'Fehlerbehandlung setzen, falls z.B. der Range auf _
einer anderen Tabelle liegt!
On Error GoTo NextO
'Schneiden sie sich?
If Not Intersect(This, Others(I)) Is Nothing Then
'Ja, Index zurückgeben
IntersectRange = I
Exit Function
End If
End If
NextO:
Next
'Nix gefunden
IntersectRange = LBound(Others) - 1
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
'Dim VX1 As Range
Dim C As Range, firstAddress As String
Dim I As Integer, Bereiche()

On Error GoTo Fehler

'Bereiche definieren
Bereiche = Array( _
Range("D31:E40"), Range("M31:N40"), Range("V31:W40"), _
Range("D68:E77"), Range("M68:N77"), Range("V68:W77"))

'In welchem Bereich wurde geàndert?
I = IntersectRange(Target, Bereiche)
Select Case I
Case -1
'In keinem
Exit Sub
Case Else
'Set VX1 = Bereiche(I)
MsgBox "Im Bereich " & Bereiche(I).Address & " wurde " & _
"eine Zelle geàndert!"

With Worksheets("Jan").Range("A4:A34")
'Set C = .Find(VX1(2, 1), LookIn:=xlValues, _
LookAt:=xlWhole)
Set C = .Find(Bereiche(I)(2, 1), LookIn:=xlValues, _
LookAt:=xlWhole)
If Not C Is Nothing Then
firstAddress = C.Address
Do
C.Value = "U"
Set C = .FindNext(C)
If C Is Nothing Then Exit Do
Loop While C.Address <> firstAddress
End If
End With
End Select
Exit Sub

Fehler:
MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
& "Beschreibung: " & Err.Description _
, vbCritical, "Fehler"
End Sub

Ähnliche fragen