Makro kopiert Hyperlink nicht mit

[Unwissender]

Hallo liebe clever-excel-Community,

ich bin absolut am Verzweifeln  - folgende Problemstellung:

Meine Excel Mappe besteht aus zwei Blättern ,,Liste" und ,,Erledigt".
Auf der ,,Liste" befinden sich in jeder Zeile Aufgaben, welche abgearbeitet werden sollen.
Sobald ich in der B-Spalte ein ,,ja" eintippe und Enter drücke, wird die entsprechende Zeile auf das ,,Erledigt"-Blatt verschoben.

Hierfür habe ich den untenstehende Code, welcher auch fehlerfrei funktioniert.

Der Knackpunkt: Es sind in der ,,Liste" auch Hyperlinks vorhanden, welche beim Verschieben verloren gehen.
D.h., dass in der ,,Erledigt" Liste nur noch der Zeileninhalt steht. Der Hyperlink ist verschwunden.

Ich bin mir sicher, dass es nur einer kleinen Änderung im Code bedarf.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lngErste As Long
    If Target.Column = 2 Then
        If Target.Count = 1 Then
            If UCase(Target) = "JA" Then
                With Worksheets("Erledigt")
                    lngErste = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
                        .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count) + 1
                    Rows(Target.Row).Copy
                    .Cells(lngErste, 1).PasteSpecial Paste:=xlValues
                    Rows(Target.Row).Delete shift:=xlUp
                End With
            End If
        End If
    End If
End Sub

Ich möchte mich im Vorfeld schon einmal für die Hilfe bedanken!

Übrigens: Ich hatte schon viel recherchiert und ähnliche Threads gefunden, jedoch weicht mein Code massiv von den dort Angegebenen ab. Dadurch helfen mir diese leider nichts...


Schöne Grüße
Unwissender

[Fennek]

Hallo,

da mit

Code:

.Cells(lngErste, 1).PasteSpecial Paste:=xlValues

eingefügt wird, ist das Ergebnis logisch (ungeprüft)

Mit einer Schleife über alle Hyperlinks des ersten Blatt, sollten diese aber auch kopiert werden können.

mfg

[Unwissender]

Hallo,

vielen Dank für die Antwort!

Wäre es für dich ein großer Umstand den Code kurz zu überarbeiten?
Ich weiß leider überhaupt nicht, wie ich das angehen soll.

Danke und schöne Grüße
Unwissender

[Kuwer]

Hallo,

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lngErste As Long
    If Target.Column = 2 Then
        If Target.Count = 1 Then
            If UCase(Target) = "JA" Then
                With Worksheets("Erledigt")
                    lngErste = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
                        .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count) + 1
                    Target.EntireRow.Cut .Cells(lngErste, 1)
                End With
            End If
        End If
    End If
End Sub

Gruß Uwe

[Unwissender]

Hallo Uwe,

vielen vielen Dank!

Funktioniert einwandfrei :18:


Schöne Grüße
Unwissender

[Unwissender]

Entschuldigt, aber eine kurze Frage noch:
 
Aktuell wird die Ganze Zeile aus der ,,Liste" ausgeschnitten und in ,,Erledigt" eingefügt - soweit so gut.
Jedoch verbleibt dann in der ,,Liste" eine weiße leere Zeile.
 
Es wäre natürlich schön, wenn diese weiße/leere verbleibende Zeile nach dem verschieben auch verschwindet.
In anderen Worten: Der Rest soll nach oben aufrücken und die Lücke schließen.
 
Das wäre doch sicherlich mit ,,Target.EntireRow.Delete" oder so ähnlich lösbar.
Wo müsste ich so einen Befehl im Code einfügen?
 
Hier noch einmal der aktuelle Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lngErste As Long
    If Target.Column = 2 Then
        If Target.Count = 1 Then
            If UCase(Target) = "JA" Then
                With Worksheets("Erledigt")
                    lngErste = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
                        .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count) + 1
                    Target.EntireRow.Cut .Cells(lngErste, 1)
                End With
            End If
        End If
    End If
End Sub
 
 
 Danke und schöne Grüße
Unwissender

[Kuwer]

Hallo,

ja stimmt, Du wolltest die Zeile ja ganz löschen. Du hattest den Befehl auch schon drin gehabt.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lngErste As Long
    If Target.Column = 2 Then
        If Target.Count = 1 Then
            If UCase(Target) = "JA" Then
                With Worksheets("Erledigt")
                    lngErste = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
                        .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count) + 1
                    Target.EntireRow.Copy .Cells(lngErste, 1)
                    Target.EntireRow.Delete
                End With
            End If
        End If
    End If
End Sub

Gruß Uwe

[Unwissender]

Vielen Dank Uwe, hat funktioniert! :)