Sub ZusammenfassenZeilen()
Dim wsh As Worksheet
Dim rngTab As Range
Dim rngRow As Range
Dim strName As String
Dim iCol As Integer, iColPos As Integer
Dim col As New Collection
Set wsh = ActiveSheet
Set rngTab = wsh.Names("Daten").RefersToRange
For Each rngRow In rngTab.Rows
If Not Intersect(Selection, rngRow) Is Nothing Then
col.Add rngRow
NewName strName, rngRow.Cells(1, 1).value
End If
Next
If col.Count > 1 Then
col.Item(1).Cells(1, 1).value = strName
For iColPos = 2 To col.Count
For iCol = 2 To rngTab.Columns.Count
If col.Item(iColPos).Cells(1, iCol).value <> "" Then
col.Item(1).Cells(1, iCol).value = col.Item(iColPos).Cells(1, iCol).value
End If
Next
col.Item(iColPos).Delete
Next
col.Item(1).Cells(1, 1).Select
End If
End Sub
Sub NewName(ByRef strName As String, ByVal value As String)
Dim iPos As Integer
Dim strPos As String
Dim strValue As String
If strName = "" Then
strName = value
Else
For iPos = 1 To Len(value)
strPos = Mid(value, iPos, 1)
If Asc(strPos) >= 48 And Asc(strPos) <= 57 Then
strValue = strValue & strPos
End If
Next
strName = strName & strValue
End If
End Sub