' **********************************************************************
' Modul: Tabelle3 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim objSh As Worksheet
Dim rngC As Range, rngF As Range
Dim lngRows() As Long, lngIndex As Long, lngC As Long, lngMatch As Long
Dim strFirst As String
Dim bolMatch As Boolean
On Error GoTo ErrExit
GMS
If Not Intersect(Target, Range("A3:F3")) Is Nothing Then
Range("A6:F" & Rows.Count) = ""
Target.Select
For Each objSh In ThisWorkbook.Worksheets
Erase lngRows
Redim lngRows(0)
bolMatch = False
Set rngC = Nothing
If Not objSh.Name = Me.Name Then
If Application.CountA(Me.Range("A3:F3")) > 0 Then
lngMatch = Me.Range("A3:F3").SpecialCells(xlCellTypeConstants).Cells(1, 1).Column
If IsNumeric(lngMatch) Then
strFirst = ""
Set rngF = objSh.Columns(lngMatch).Find(What:=Me.Cells(3, lngMatch), LookAt:=xlWhole, LookIn:=xlValues, _
MatchCase:=False, SearchFormat:=False)
If Not rngF Is Nothing Then
strFirst = rngF.Address
Do
If rngF.Row > 1 Then
If IsError(Application.Match(rngF.Row, lngRows, 0)) Then
bolMatch = True
Redim Preserve lngRows(lngIndex)
lngRows(lngIndex) = rngF.Row
For lngC = lngMatch + 1 To 6
If Me.Cells(3, lngC) <> "" Then
bolMatch = LCase(objSh.Cells(rngF.Row, lngC)) Like LCase(Me.Cells(3, lngC))
End If
Next
End If
If bolMatch Then
If rngC Is Nothing Then
Set rngC = rngF.EntireRow
Else
Set rngC = Union(rngC, rngF.EntireRow)
End If
End If
End If
Set rngF = objSh.Columns(lngMatch).FindNext(rngF)
Loop While Not rngF Is Nothing And rngF.Address <> strFirst
End If
End If
If Not rngC Is Nothing Then
rngC.Copy Me.Cells(Me.Rows.Count, 1).End(xlUp).Offset(1, 0)
End If
End If
End If
Next
End If
ErrExit:
GMS True
Set objSh = Nothing
Set rngF = Nothing
Set rngC = Nothing
End Sub
Public Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Not Modus Then lngCalc = .Calculation
If Modus And lngCalc = 0 Then lngCalc = -4105
.Calculation = IIf(Modus, lngCalc, -4135)
.Cursor = IIf(Modus, -4143, 2)
End With
End Sub