Sub copylinks()
' copy der aktuellen Zelle nach unten, bis zur höchsten befüllten Zeilennr. weiter links
Dim bs As Variant
Dim bz As Variant
Dim prf As Variant
Dim af As Variant
bs = ActiveCell.Column
bz = ActiveCell.Row
' sicherstellen, dass zu befüllender Bereich leer
Selection.End(xlDown).Select
If ActiveCell.Row "" Then Stop
' letzte Zeile der nächstbefüllten Spalte links (bzw. rechts, wenn´um Spalte A geht) daneben _
feststellen
prf = 0
10
prf = prf + 1
If bs = 1 Then prf = prf - 2
Cells(65536, bs - prf).End(xlUp).Select
af = ActiveCell.Row
If af bs Then Stop
' kann sein, wenn A1 verbundene Zelle
' Verzweigung wenn "uw" oder "uwf"
Stop
' Bei Fehler geht die Abfrage nicht, deshalb vorab bei Fehler goto 30
' If Left(Selection.Text, 1) = "#" Then GoTo 30
If IsError(Selection(1)) Then GoTo 30
'if Selection = "fehlermeldung, wie auch immer das hinzubekommen ist) then goto 30
If Selection = "uw" Then GoTo 700
If Selection = "uwf" Then GoTo 750
30
Selection.Copy
ActiveCell.Offset(0, 0).Range(af).Select
ActiveSheet.Paste
'zum Ende springen bzw. Anfang, wenn rechts noch was kommt
Selection.End(xlToRight).Select
If ActiveCell.Column 1 Then Stop
ActiveCell.Offset(1, 0).Range("A1").Select
'ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(MATCH(RC[-1],R1C[-1]:R[-1]C,0)),RC[-1],"""")"
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(MATCH(RC[-1],R1C[-1]:R[-1]C[-1],0)),RC[-1],"""")"
Selection.Copy
ActiveCell.Offset(0, 0).Range(af).Select
ActiveSheet.Paste
Stop
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.End(xlDown).Select
Selection.ClearContents
Range("A1").Select
ActiveCell.Offset(bz - 1, bs - 1).Range("A1").Select
ActiveCell.FormulaR1C1 = "=RC[-1]"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(MATCH(RC[-1],R[-5]C:R[-1]C,0)),RC[-1],"""")"
GoTo 990
750
' Warnung falls Vorzeile nicht sortiert, Formel für unterschiedliche Werte einkopieren
Stop
' under construction, copyteil:
Selection.Copy
ActiveCell.Offset(0, 0).Range(af).Select
ActiveSheet.Paste
960
Range("A1").Select
ActiveCell.Offset(bz - 1, bs - 0).Range("A1").Select
GoTo 990
980
Selection.End(xlToLeft).Select
Selection.End(xlDown).Select
990
End Sub