Microsoft Excel

Herbers Excel/VBA-Archiv

Hyperlinks entfernen/Bilder löschen per Makro

Betrifft: Hyperlinks entfernen/Bilder löschen per Makro von: Christian
Geschrieben am: 11.09.2014 22:27:16

Hallo an alle,

seid ihr so nett und helft mir, unten stehendes Makro zu ändern? In sofern, dass bevor es das tut, was es im Moment tut im Sheet 1 alle Hyperlinks in den Spalten B und D entfernt, sowie alle Bilder entfernt.

Gruß und vielen Dank
Christian

Sub aa()
      Dim hl As Hyperlink, s, ttd
      For Each hl In Sheets(1).Hyperlinks
        On Error Resume Next
        ttd = hl.TextToDisplay
        On Error GoTo 0
        If ttd Like ("Season*") Or ttd Like ("Episode*") Then
          s = Split(hl.Address, "/")
          s = s(UBound(s) + (s(UBound(s)) = ""))
          With Sheets(2).Cells(Rows.Count, 1).End(xlUp)
            .Offset(1) = s
            .Offset(1, 2) = hl.Parent.Offset(2)
          End With
        End If
      Next
      With Sheets(2)
        .Range("A:G").Sort key1:=.Range("A1"), order1:=xlAscending, Header:=xlNo
      End With
      With Sheets(1)
        .Cells.Clear
             End With
    End Sub

  

Betrifft: AW: Hyperlinks entfernen/Bilder löschen per Makro von: Martin
Geschrieben am: 11.09.2014 22:43:47

Hallo Christian,

hier mein Vorschlag:

Sub aa()
    Dim hl As Hyperlink, s, ttd
    Dim objElement As Object
    
    With Sheets(1)
        'Hyperlinks löschen
        .Columns("B:B,D:D").Hyperlinks.Delete
    
        'Alle Bilder löschen
        For Each objElement In .Pictures
            objElement.Delete
        Next
    End With
    
    For Each hl In Sheets(1).Hyperlinks
        On Error Resume Next
        ttd = hl.TextToDisplay
        On Error GoTo 0
        If ttd Like ("Season*") Or ttd Like ("Episode*") Then
            s = Split(hl.Address, "/")
            s = s(UBound(s) + (s(UBound(s)) = ""))
            With Sheets(2).Cells(Rows.Count, 1).End(xlUp)
                .Offset(1) = s
                .Offset(1, 2) = hl.Parent.Offset(2)
            End With
        End If
    Next
    
    With Sheets(2)
      .Range("A:G").Sort key1:=.Range("A1"), order1:=xlAscending, Header:=xlNo
    End With
    
    With Sheets(1)
        .Cells.Clear
    End With
End Sub
Viele Grüße

Martin


  

Betrifft: AW: Hyperlinks entfernen/Bilder löschen per Makro von: Christian
Geschrieben am: 12.09.2014 08:22:50

Hallo Martin,

Excel sagt mir leider, irgendwelche Typen wären unverträglich.
Wenn ich vor die Zeile .Columns("B:B,D:D").Hyperlinks.Delete ein ' setze funktioniert es, außer dass er natürlich keine Links löscht.
Danke schonmal

Christian


  

Betrifft: AW: Hyperlinks entfernen/Bilder löschen per Makro von: Christian
Geschrieben am: 12.09.2014 08:35:22

Hallo Martin,

Excel sagt mir leider, irgendwelche Typen wären unverträglich.
Wenn ich vor die Zeile .Columns("B:B,D:D").Hyperlinks.Delete ein ' setze funktioniert es, außer dass er natürlich keine Links löscht.
Danke schonmal

Christian


  

Betrifft: sorry doppelt von: Christian
Geschrieben am: 12.09.2014 08:36:11

.


  

Betrifft: AW: sorry doppelt von: Martin
Geschrieben am: 12.09.2014 11:25:44

Hallo Christian,

ja, das war ein Fehler von mir. So sollte es aber wirklich klappen:

Sub aa()
    Dim hl As Hyperlink, s, ttd
    Dim objElement As Object
    
    With Sheets(1)
        'Hyperlinks löschen
        .Range("B:B,D:D").Hyperlinks.Delete
    
        'Alle Bilder löschen
        For Each objElement In .Pictures
            objElement.Delete
        Next
    End With
    
    For Each hl In Sheets(1).Hyperlinks
        On Error Resume Next
        ttd = hl.TextToDisplay
        On Error GoTo 0
        If ttd Like ("Season*") Or ttd Like ("Episode*") Then
            s = Split(hl.Address, "/")
            s = s(UBound(s) + (s(UBound(s)) = ""))
            With Sheets(2).Cells(Rows.Count, 1).End(xlUp)
                .Offset(1) = s
                .Offset(1, 2) = hl.Parent.Offset(2)
            End With
        End If
    Next
    
    With Sheets(2)
        .Range("A:G").Sort key1:=.Range("A1"), order1:=xlAscending, Header:=xlNo
    End With
    
    With Sheets(1)
        .Cells.Clear
    End With
End Sub
Viele Grüße

Martin


  

Betrifft: AW: sorry doppelt von: Christian
Geschrieben am: 12.09.2014 11:38:02

Hallo Martin,

Fehler können passieren. Überhaupt kein Problem. So funktioniert es jedenfalls.
Auf jeden Fall vielen Dank für deine Mühe und ein schönes Wochenende.

Gruß
Christian


 

Beiträge aus den Excel-Beispielen zum Thema "Hyperlinks entfernen/Bilder löschen per Makro"