|   Datum   |  ErrText  | Seq-No  |   Details    |
---+-----------+-----------+---------+--------------+-
 1 | 19-Aug-03 | Fehler 30 |       3 | Datensatz 25 |
---+-----------+-----------+---------+--------------+-
 2 | 16-Aug-03 | Fehler 30 |      16 | Datensatz 17 |
---+-----------+-----------+---------+--------------+-
 3 | 18-Aug-03 | Fehler 30 |      61 | Datensatz  7 |
---+-----------+-----------+---------+--------------+-

   |   Datum   |  ErrText  | Seq-No  |   Details    |
---+-----------+-----------+---------+--------------+-
 1 | 18-Aug-03 | Fehler 30 |       3 | Datensatz 25 |
   |           |           |         | Datensatz  7 |
---+-----------+-----------+---------+--------------+-
 2 | 16-Aug-03 | Fehler 30 |      16 | Datensatz 17 |
---+-----------+-----------+---------+--------------+-
 3 |           |           |         |              |
---+-----------+-----------+---------+--------------+-

Sub join_rows()
Dim minRow, maxRow, minCol, maxCol, i, j As Long
Dim Cel As Range
Dim NewCont As String
' finden der äußersten Zellen - ANFANG
minRow = ActiveCell.Row
maxRow = minRow
minCol = ActiveCell.Column
maxCol = minCol
For Each Cel In Selection
    minRow = IIf(minRow < Cel.Row, minRow, Cel.Row)
    maxRow = IIf(maxRow > Cel.Row, maxRow, Cel.Row)
    minCol = IIf(minCol < Cel.Column, minCol, Cel.Column)
    maxCol = IIf(maxCol > Cel.Column, maxCol, Cel.Column)
Next Cel
 
If minRow = maxRow Then
    MsgBox "You have to select a minimum of two rows before using this" & _
      "function.", vbOKOnly + vbCritical
    Exit Sub
End If
' finden der äußersten Zellen - ANFANG
' Beginne bei der äußersten Zeile oben und gehe dann Zeilenweise weiter
' i = Zeilennummer
For i = minRow + 1 To maxRow
' Ist eine Zelle der aktuellen Zeile i markiert ?
    j = 1 ' Vorgabewert j = 1 keine Markierte Zelle in dieser Zeile
    For Each Cel In Selection
    	' j wird = 0 wenn eine Zelle gefunden wird, die in dieser Zeile markiert 
    ' ist.
        If i = Cel.Row Then j = 0
    Next Cel
' Wenn eine Zelle der aktuellen Zeile i markiert ist (j=0)?
    If j = 0 Then
' dann werden die Spalten dieser Zeile i mit den Spalten der Zeile nimrow 
' verbunden
        For j = minCol To maxCol
' für alle Spalten j
            If IsNumeric(Cells(i, j)) Or IsDate(Cells(i, j)) Then
' bei Zellen mit Zahlen oder Datum wird nur das Minimum behalten (der Kleiste 
' bzw. der Älteste)
                Cells(minRow, j) = IIf(Cells(i, j) < Cells(minRow, j), Cells(i, _
                  j), Cells(minRow, j))
            ElseIf InStr(Cells(minRow, j).Text, Cells(i, j).Text) = 0 Then
' bei allen anderen wird neuer Text mit Zeilenschaltung (vblf) getrennt 
' angehängt
                Cells(minRow, j) = Cells(minRow, j) & vbLf & Cells(i, j)
            End If
        Next j
' Mit dem Inhalt bis bald wird die Zeile zum Löschen vorgemerkt
        Cells(i, minCol) = "bis Bald"
    End If
Next i
For i = maxRow To minRow + 1 Step -1
    If Cells(i, minCol) = "bis Bald" Then
' Zeile Löschen
       Cells(i, minCol).EntireRow.Delete
    End If
Next i
Cells(minRow, minCol).Select
End Sub