Hyperlink-Adressen in seperatem Blatt auflisten

Hallo an euch alle,
suche eine möglichst (aufgrund der Menge an Inhalten) zeitsparende Möglichkeit, folgendes zu realisieren und würde mich freuen, wenn ihr mich beratet wie das möglichst schnell geht.
Es geht um ca. 300 Internetseiten, die ich nacheinander vorhabe in Tabelle 1 zu kopieren.
Wenn ich die erste Seite kopiert habe, stehen in den Zellen A8, A20, A32, A44, A56, A68, A80, A92 und A104 Hyperlinks.
Es gibt noch mehr Hyperlinks, aber die anderen sind irrelevant.
Mein Ziel ist es in Tabelle2 die Adressen dieser Hyperlinks aufzulisten, von allen 300 Seiten.
Und nach jeder neuen Auflistung Tabelle1 wieder zu löschen, da jedesmal auch viele Bilder dabei sind und die Rechenzeit sich extrem aufblähen würde.
Also nochmal kurz zusammengefasst:
1. Ich kopiere den Inhalt einer Internetseite nach Tabelle1
2. die Adressen der Hyperlinks in oben genannten Zellen sollen in Tabelle2 aufgelistet werden.
3. Der Inhalt von Tabelle1 soll inkl. der Bilder wieder gelöscht werden.
Habt ihr eine Idee wie sich das möglichst mit wenig Zeitaufwand für mich realisieren lässt?
Gruß, danke und guten Rutsch
Jenny
PS: Es ist nicht so zeitkritisch, dass jemand sich die Mühe an Silvester oder am Neujahrstag machen muss, feiert lieber schön.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Linkadressen() Dim lngZeile As Long Dim lngZiel As Long Dim shaShape As Shape With Worksheets("Tabelle2") lngZiel = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, . _ Rows.Count) + 1 For lngZeile = 8 To 104 Step 12 If Cells(lngZeile, 1).Hyperlinks.Count > 0 Then .Cells(lngZiel, 1) = Cells(lngZeile, 1).Hyperlinks(1).Address lngZiel = lngZiel + 1 End If Next lngZeile End With ActiveSheet.Cells.Clear For Each shaShape In ActiveSheet.Shapes shaShape.Delete Next shaShape End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Set Target = Application.Intersect(Target, Range("A1:A110")) If Target Is Nothing Then Exit Sub On Error GoTo ErrorHandler Application.EnableEvents = False Dim rngZelle As Range For Each rngZelle In Target Dim lngZeile As Long Dim lngZiel As Long Dim shaShape As Shape With Worksheets("Tabelle2") lngZiel = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, . _ _ Rows.Count) + 1 For lngZeile = 8 To 104 Step 12 If Cells(lngZeile, 1).Hyperlinks.Count > 0 Then .Cells(lngZiel, 1) = Cells(lngZeile, 1).Hyperlinks(1).Address lngZiel = lngZiel + 1 End If Next lngZeile End With With Worksheets("Tabelle1") ActiveSheet.Cells.Clear For Each shaShape In ActiveSheet.Shapes shaShape.Delete Next shaShape End With Next rngZelle ErrorHandler: Application.EnableEvents = True End Sub

...mit deinem Code wird das Change-Ereignis mehrmals ausgeführt, die Daten also mehrfach übertragen werden (da du in einer Schleife über jede Zelle im Bereich A1:A110 läufst) - was sicher nicht Sinn und Zweck des ganzen sein soll. Ich nehme an, dass du immer den Cursor in A1 setzt und dann das Kopierte einfügst - in dem Fall reicht dies aus:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lngZeile As Long
Dim lngZiel As Long
Dim shaShape As Shape
If Target.Cells(1).Address(False, False) = "A1" Then
With Worksheets("Tabelle2")
If .Range("A1") = "" Then
lngZiel = 1
Else
lngZiel = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp). _
Row, .Rows.Count) + 1
End If
For lngZeile = 8 To 104 Step 12
If Cells(lngZeile, 1).Hyperlinks.Count > 0 Then
.Cells(lngZiel, 1) = Cells(lngZeile, 1).Hyperlinks(1).Address
lngZiel = lngZiel + 1
End If
Next lngZeile
End With
Application.EnableEvents = False
ActiveSheet.Cells.Clear
Application.EnableEvents = True
For Each shaShape In ActiveSheet.Shapes
shaShape.Delete
Next shaShape
End If
End Sub

Ich hatte angenommen, dass in Zeile 1 der Tabelle2 eine Überschrift steht - Code ist entsprechend geändert.

Sub test() Columns("A").Clear MsgBox "Spalte A wurde geleert" MsgBox "Spalte A hat " & Columns("A").Rows.Count & " Zeilen" MsgBox "Zeile letzter gefüllter Zelle in Spalte A: = " & Cells(Rows.Count, 1).End(xlUp).Row MsgBox "Die allerletzte Zelle in Spalte A wird mit XXX gefüllt" Cells(Rows.Count, 1) = "XXX" MsgBox "Zeile letzter gefüllter Zelle in Spalte A: = " & Cells(Rows.Count, 1).End(xlUp).Row MsgBox " Weil das Ergebnis nicht stimmt, nehmen wir diese Ausnahme mit in die Abfrage" Dim loLetzte As Long loLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count) MsgBox "Letzte Zeile: " & loLetzte MsgBox "Jetzt setzen wir für die nächste freie Zelle darunter #loLetzte + 1" Cells(loLetzte + 1, 1).Select End Sub

Beliebteste Forumthreads (12 Monate)

Hyperlink-Adressen in seperatem Blatt auflisten

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread