'
'Klassenmodul: wksZusammenfassung (Zusammenfassung)
'
Option Explicit

Friend Function SchreibeEintrag(Gebaude, Standort, Bezeichnung, Optional SN, Optional ID, Optional EQUI) As Long
  
  If Trim$(Gebaude) = "" Or Trim$(Standort) = "" Or Trim$(Bezeichnung) = "" Then
    Exit Function
  ElseIf IsMissing(SN) And IsMissing(ID) And IsMissing(EQUI) Then
    Exit Function
  End If
  
  Dim rngGebaude      As Excel.Range
  Dim rngStandort     As Excel.Range
  Dim rngBezeichnung  As Excel.Range
  Dim rngSN           As Excel.Range
  Dim rngID           As Excel.Range
  Dim rngEQUI         As Excel.Range
  
  Set rngGebaude = Range("A2", Cells(Rows.Count, "A").End(xlUp))
  
  If rngGebaude.Row >= 2 Then
  'den Eintrag [<Gebaude>+<Standort>+<Bezeichnung>] in den bereits existierenden Einträgen suchen
    Dim rngTreffer  As Excel.Range
    Dim strTreffer1 As String
    Dim blnTreffer  As Boolean
    Set rngTreffer = rngGebaude.Find(Gebaude, , xlValues, xlWhole, xlByColumns, , False)
    If Not rngTreffer Is Nothing Then
      strTreffer1 = rngTreffer.Address
      Do
        Set rngStandort = rngTreffer.Offset(0, 1)
        Set rngBezeichnung = rngTreffer.Offset(0, 2)
        If rngStandort.Value = Standort And rngBezeichnung.Value = Bezeichnung Then
          blnTreffer = True
          Exit Do
        End If
        Set rngTreffer = rngGebaude.FindNext(rngTreffer)
      Loop While rngTreffer.Address <> strTreffer1
    End If
    If blnTreffer = False Then
      'Stelle zum Schreiben anpassen
      Set rngTreffer = rngGebaude.Offset(rngGebaude.Rows.Count).Cells(1)
    End If
  Else
    'Stelle zum Schreiben anpassen
    Set rngTreffer = Range("A2")
  End If
  
  Application.EnableEvents = False
  
  If blnTreffer = False Then
    Set rngGebaude = rngTreffer
    Set rngStandort = rngTreffer.Offset(0, 1)
    Set rngBezeichnung = rngTreffer.Offset(0, 2)
    Set rngSN = rngTreffer.Offset(0, 3)
    Set rngID = rngTreffer.Offset(0, 4)
    Set rngEQUI = rngTreffer.Offset(0, 5)
    'neuen Eintrag erstellen
    rngGebaude.Value = Gebaude
    rngStandort.Value = Standort
    rngBezeichnung.Value = Bezeichnung
  Else
    Set rngGebaude = rngTreffer
    Set rngStandort = rngTreffer.Offset(0, 1)
    Set rngBezeichnung = rngTreffer.Offset(0, 2)
    Set rngSN = rngTreffer.Offset(0, 3)
    Set rngID = rngTreffer.Offset(0, 4)
    Set rngEQUI = rngTreffer.Offset(0, 5)
  End If
  
  'Wert(e) des Eintrags setzen
  If Not IsMissing(SN) Then rngSN.Value = SN
  If Not IsMissing(ID) Then rngID.Value = ID
  If Not IsMissing(EQUI) Then rngEQUI.Value = EQUI
  
  Application.EnableEvents = True
  
  SchreibeEintrag = rngGebaude.Row
  
End Function

'
'Klassenmodul: ????? (Gebäude A)
'
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  
  Dim rngTargetCell   As Excel.Range
  Dim strGebaude      As String
  Dim strStandort     As String
  Dim strBezeichnung  As String
  Dim vntSN           As Variant
  Dim vntID           As Variant
  Dim vntEQUI         As Variant
  
  'Eingabe in mehrere Zellen gleichzeit unterstützen
  For Each rngTargetCell In Target.Cells
    If rngTargetCell.Row >= 3 Then
      strGebaude = rngTargetCell.Worksheet.Name
      strStandort = Cells(rngTargetCell.Row, "A").Value
      strBezeichnung = Cells(1, rngTargetCell.Column).MergeArea.Cells(1).Value
      Select Case ((rngTargetCell.Column - Columns("B").Column) Mod 3)
        Case 0 'SN
          Call wksZusammenfassung.SchreibeEintrag( _
                  Gebaude:=strGebaude, _
                  Standort:=strStandort, _
                  Bezeichnung:=strBezeichnung, _
                  SN:=rngTargetCell.Value)
        Case 1 'ID
          Call wksZusammenfassung.SchreibeEintrag( _
                  Gebaude:=strGebaude, _
                  Standort:=strStandort, _
                  Bezeichnung:=strBezeichnung, _
                  ID:=rngTargetCell.Value)
        Case 2 'EQUI
          Call wksZusammenfassung.SchreibeEintrag( _
                  Gebaude:=strGebaude, _
                  Standort:=strStandort, _
                  Bezeichnung:=strBezeichnung, _
                  EQUI:=rngTargetCell.Value)
      End Select
    End If
  Next
  
End Sub

Grüße