Hyperlinks per Makro auslesen
09.07.2015 16:05:23
Jenny
ich bitte um Hilfe unten stehendes Makro zu erweitern.
Mir ist bekannt, dass die Kommentare nicht mit dem was das Makro macht übereinstimmen, ich war zu faul die Kommentare abzuändern.
Wie ihr seht werden ziemlich am Anfang des Makros Inhalte von Tabelle2 Spalte B nach Tabelle 1 Spalte E kopiert.
Die kopierten Zellen haben alle einen Hyperlink, dessen Ziel folgendermaßen aussieht:
http://www.imdb.com/name/nmxxxxxxx/ wobei die x für eine beliebige siebenstellige Zahl stehen.
Ist es möglich, dass das Makro für jede kopierte Zelle den code nmxxxxxxx ohne das / am Schluss in Tabelle1 Spalte D schreibt?
Vielen Dank für die Mühe
Jenny
Sub Makro1()
Dim zt1, von, bis As Long
Dim Grafiken As Shape
Application.ScreenUpdating = False
With Sheets("Tabelle1")
zt1 = .Cells(.Rows.Count, 1).End(xlUp).Row
von = 1
With Sheets("Tabelle2")
bis = .Cells(.Rows.Count, 2).End(xlUp).Row
'Inhalt Spalte B nach tabelle1 kopieren
.Range(.Cells(von, 2), .Cells(bis, 2)).Copy Sheets("Tabelle1").Cells(zt1, 5)
End With
With Sheets("Tabelle3")
'Inhalt aus Spalte E kopieren
.Range(.Cells(von, 5), .Cells(bis, 5)).Copy
End With
'In Spalte D einfügen
.Cells(zt1, 5).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
If bis > 1 Then
'Spalte A und B durch kopieren auffüllen
.Range(.Cells(zt1, 1), .Cells(zt1, 3)).Copy _
Destination:=.Range(.Cells(zt1 + 1, 1), .Cells(zt1 + bis - von, 1))
End If
Application.CutCopyMode = False
'Daten nach Spalte D absteigend sortieren
.Range(.Cells(1, 1), .Cells(zt1 + 1 + bis - von, 7)).Sort _
key1:=.Range("C1"), Order1:=xlAscending, _
key2:=.Range("E1"), Order2:=xlDescending, Header:=xlNo
End With
With Sheets("Tabelle2")
'Daten in Spalten A bis C löschen
.Range(.Cells(1, 1), .Cells(bis, 3)).Clear
End With
With Sheets("Tabelle3")
'Daten in Spalten A bis D löschen
.Range(.Cells(1, 1), .Cells(bis, 4)).Clear
For Each Grafiken In .Shapes
Grafiken.Delete
Next
End With
Application.ScreenUpdating = True
End Sub