Ereignisabfrage

Private Sub Worksheet_Change(ByVal Target As Range) Dim loZeile As Long Dim Sh As Worksheet Dim chk As Boolean loZeile = Target.Row '--- Prüfungen------ If Target.Column 7 Then Exit Sub If loZeile 33 Then Exit Sub chk = False For Each Sh In ActiveWorkbook.Sheets If Sh.Name = Right(Cells(loZeile, 13), 4) Then chk = True Exit For End If Next If chk = False Then MsgBox "kein passendes Arbeitsblatt gefunden" Exit Sub End If '----Kopieren und löschen----------------------- Application.EnableEvents = False Application.ScreenUpdating = False Sh.Unprotect Me.Unprotect Rows(loZeile).Copy Sh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteFormulas Rows(loZeile).EntireRow.Delete Application.CutCopyMode = False Me.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True Sh.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True Application.ScreenUpdating = True Application.EnableEvents = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Ereignisabfrage

30.05.2009 19:13:50

Josef

AW: Ereignisabfrage

30.05.2009 19:43:37

H.Schult

AW: Ereignisabfrage

30.05.2009 21:03:56

Josef

AW: Ereignisabfrage

30.05.2009 20:17:05

Raist10

AW: Ereignisabfrage

30.05.2009 21:11:16

H.Schult

AW: Ereignisabfrage

30.05.2009 21:22:39

Raist10

Hallo ACR (realnames hat man hier gerne)
ungetestet!

' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Sh As Worksheet

  With Target
    '--- Prüfungen------
    If .Column = 6 Or .Column = 7 Or .Column = 9 Or .Column = 10 Then
      If .Row > 7 And .Row < 34 Then
        If Application.CountA(Cells(.Row, 6), Cells(.Row, 7), Cells(.Row, 9), Cells(.Row, 10)) = 4 Then
          On Error Resume Next
          Set Sh = Sheets(Right(Cells(.Row, 13), 4))
          Err.Clear
          On Error GoTo 0
          If Not Sh Is Nothing Then
            '----Kopieren und löschen-----------------------
            On Error GoTo ErrExit
            Application.EnableEvents = False
            Application.ScreenUpdating = False
            Sh.Unprotect
            Me.Unprotect
            Sh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = Rows(.Row)
            Rows(.Row).Delete
            Me.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
            Sh.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
          Else
            MsgBox "kein passendes Arbeitsblatt gefunden"
          End If
        End If
      End If
    End If
  End With

  ErrExit:

  Application.ScreenUpdating = True
  Application.EnableEvents = True

End Sub

Gruß Sepp

Probiere es mal so:
Option Explicit


Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngBer As Range
Dim rngObj As Range
Dim Sh As Worksheet
On Error GoTo Err_Handler
' zu prüfende zellen als gesamt bereich festlegen
With Me
Set rngBer = Union(.Range("F8:F33"), .Range("G8:G33"), .Range("I8:I33"), _
.Range("J8:J33"))
End With
' gucken ob change im zielbereich liegt
If Not Intersect(Target, rngBer) Is Nothing Then
With Target
' wenn ja, abfrage ob alle zellen gefüllt sind, wenn eine leer dann raus aus sub
For Each rngObj In rngBer
' nur wenn zeile stimmt inhalt prüfen
If rngObj.Row = .Row Then
' wenn zeile stimmt, aber einer der 4 checkbereich leer dann exit
If rngObj.Value = "" Then
GoTo Exit_This
End If
End If
Next rngObj
' sheetauswahl nach angabe im tabellenblatt, spalte m
' nicht existent wird im err_handler abgearbeitet
Set Sh = Sheets(Right(Cells(.Row, 13), 4))
Application.EnableEvents = False
Application.ScreenUpdating = False
Sh.Unprotect
Me.Unprotect
' zeile kopieren ins neue sheet
Rows(.Row).Copy Destination:=Sh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
' zeile im ursprungssheet löschen
Rows(.Row).Delete
Me.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Sh.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
End If
Exit_This:
Application.EnableEvents = True
Application.ScreenUpdating = True
Set rngBer = Nothing
Set rngObj = Nothing
Set Sh = Nothing
Exit Sub
Err_Handler:
Select Case Err.Number
Case 9
MsgBox "Das angegebene Tabellenblatt existiert nicht!"
Case Else
MsgBox "Fehler: " & Err.Number & vbLf & Err.Description
End Select
Resume Exit_This
End Sub

Gruß Rainer

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread