|
Ich habe ehrlich, nicht die leiseste Ahnung wozu (jemand für so eine einfache Fingerübung ein Makro benötigt)
Sub Tust()
'frei nach Tushar Mehta
Dim FirstCell As Range, HitCell As Range
With Application.FindFormat
.Clear
.MergeCells = True
End With
Set FirstCell = Cells.Find(What:="", After:=Cells(1, 1), _
LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=True)
If Not FirstCell Is Nothing Then
Dim CurrCell As Range, Rslt As String
Set CurrCell = FirstCell
Do
With CurrCell
If Not Intersect(CurrCell, Columns("A:B")) Is Nothing Then
If .HorizontalAlignment = -4108 Or .HorizontalAlignment = 7 Then
If Not HitCell Is Nothing Then
Set HitCell = Union(HitCell, CurrCell)
Else
Set HitCell = CurrCell
End If
End If
End If
End With
Rslt = Rslt & CurrCell.Address & ","
Set CurrCell = Cells.Find(What:="", After:=CurrCell, _
LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=True)
Loop Until CurrCell.Address = FirstCell.Address
Application.DisplayAlerts = False
With HitCell
.HorizontalAlignment = 1
.UnMerge
End With
Application.DisplayAlerts = True
End If
End Sub
|