Hyperlinks per Makro auslesen

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Hyperlinks per Makro auslesen
von: Jenny
Geschrieben am: 09.07.2015 16:05:23

Hallo an alle,
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

Bild

Betrifft: AW: Hyperlinks per Makro auslesen
von: Silent_Warrior5
Geschrieben am: 09.07.2015 17:59:18
Hi,
verwende einfach die Funktion MID (Teil) und FIND (zum Zeichenfinden) und schneide dir das passende einfach raus. Oder mach ne Hilfsspalte dahinter wo du einfach das ganze als Excel Formel mit =Teil(.... machst. Wenn der Hyperlink immer die gleiche Länge hat dann brauchste auch oben das FIND nicht.
Gruß
SW5

Bild

Betrifft: AW: Hyperlinks per Makro auslesen
von: Jenny
Geschrieben am: 09.07.2015 19:31:45
Hallo SW5,
ich befürchte du hast etwas falsch verstanden. oder zumindest ist es mir neu, dass man sich per Formel das Ziel eines Hyperlinks ausgeben lassen kann. Es geht hier ja nicht um den Text, der in der Zelle steht.
Außerdem geht es hier darum, mit diesem Makro 4200 Texte zusammenzufassen, dieses Makro ist also für mich eine extreme Zeitersparnis und es wäre nochmal eine menge Zeitersparnis, wenn es das mitübernehmen würde.
LG
Jenny
PS: Hab mich in nicht für die Bitte relevanten Teilen noch bei Zellbezügen vertan, hier das korrekte Makro

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, 6), .Cells(bis, 6)).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, 8)).Sort _
         key1:=.Range("C1"), Order1:=xlAscending, _
        key2:=.Range("F1"), 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


Bild

Betrifft: AW: Hyperlinks per Makro auslesen
von: Mullit
Geschrieben am: 09.07.2015 20:23:23
Hallo,

ich war zu faul die Kommentare abzuändern.

das ist ja immerhin offen, frei und geradeheraus, nur warum sollten wir dann motivierter sein und Dir etwas coden...
Gruß, Mullit

Bild

Betrifft: AW: Hyperlinks per Makro auslesen
von: Jenny
Geschrieben am: 09.07.2015 20:26:49
Jetzt stimmen die Kommentare, helft ihr mir bitte jetzt?

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 E einfügen
         .Cells(zt1, 5).PasteSpecial Paste:=xlPasteValues
         Application.CutCopyMode = False
        If bis > 1 Then
          'Spalte A bis C 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 C aufsteigend, dann F absteigend sortieren
        .Range(.Cells(1, 1), .Cells(zt1 + 1 + bis - von, 8)).Sort _
         key1:=.Range("C1"), Order1:=xlAscending, _
        key2:=.Range("F1"), 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


Bild

Betrifft: AW: Hyperlinks per Makro auslesen
von: Silent_Warrior5
Geschrieben am: 10.07.2015 17:41:43
Hi, vielleicht drückst du dich nicht richtig aus.
1.Woher kommen denn die Texte? Dort ist keine Webabfrage hinterlegt in dem Marko. 2 Was sind das für Texte? 3. Was heist das Ziel eines Hyperlinks? Ne Beispieltdatei würde sicher helfen, da wir keine Glaskugel haben.
Gruß
SW5

Bild

Betrifft: AW: Hyperlinks per Makro auslesen
von: Jenny
Geschrieben am: 10.07.2015 20:44:19
Hallo SW5,
sorry ich dachte das wäre eindeutig,
die Texte werden aus Tabelle2 Spalte B durch das Makro in Tabelle 1 Spalte G (hab noch ein paar Spalten dazwischeneingefügt in der Zwischenzeit, stehen also beim starten des Makros bereits in Tabelle2.
Daher ist auch keine Webabfrage benötigt.
Mit Ziel des Hyperlinks meine ich die Internetseite die sich öffnet, wenn ich den Text mit dem Hyperlink anklicke.
Hier mal ein kleines Beispiel, wie das aussieht.
Durch das Ausfüren des Makros, wird in Tabelle1 der Bereich G4:H5 gefüllt.
Wenn du mal schaust, ist das was in Spalte F steht ein Teil des Hyperlinks der in Spalte G steckt, mein Wunsch wäre gewesen, dass das Makro, wenn es etwas in Spalte G schreibt, gleichzeitig Spalte F füllt, so wie es bereits in den ersten 3 Zeilen in Tabelle 1 steht.
Gruß
Jenny
PS schau mal im Moment helf ich mir aus, in dem ich diese UDF benutze


Function extHlAdr(Zelle As Range)
    extHlAdr = Zelle.Hyperlinks(1).Address
End Function
Function Splitt(Bezug, Optional ByVal Trenner)
    Splitt = Split(Bezug, Trenner)
End Function
mit der Formel
=INDEX(Splitt(extHlAdr(G1);"/");ANZAHL2(Splitt(extHlAdr(G1);"/"))-1)
allerdings muss ich die UDF jedesmal trotzdem kopieren, sie wird nicht automatisch eingefügt. Wenn ich sie im Vorfeld über tausende Zeilen einfüge wird im Makro die Variable bis also die letzte Zeile falsch berechnet.
Vielleicht kannst du ja etwas von diesem Ansatz gebrauchen.
und PPS: als ich den Thread eröffnet hatte, hatte ich die UDF noch nicht sonst hätte ich natürlich vorher schon davon geschrieben.
https://www.herber.de/bbs/user/98762.xlsm

Bild

Betrifft: So?
von: Michael
Geschrieben am: 10.07.2015 21:53:53
Hi Jenny,
versuch bitte das mal; die neuen Zeilen habe ich mit *** markiert (und heimlich das zt1 mit +1 versehen, nur damit Du es wieder entfernen kannst, falls nötig):

Sub Makro1()
'
' Makro1 Makro
'
' Tastenkombination: Strg+i
'
     Dim zt1&, von&, bis As Long
     Dim Grafiken As Shape
'*****************
     Dim c As Range, a As Variant
'*****************
     Application.ScreenUpdating = False
     With Sheets("Tabelle1")
         zt1 = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
         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, 7)
         End With
         With Sheets("Tabelle3")
             'Inhalt aus Spalte E kopieren
             .Range(.Cells(von, 5), .Cells(bis, 5)).Copy
         End With
         'In Spalte H einfügen
         .Cells(zt1, 8).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
'         Stop
'*****************
         For Each c In Range(.Cells(zt1, 7), .Cells(zt1 + bis - von + 1, 7))
           If c.Hyperlinks.Count > 0 Then
              a = Split(c.Hyperlinks(1).Address, "/")
'              For i = 1 To UBound(a): MsgBox a(i): Next
              c.Offset(0, -1).Value = a(UBound(a) - 1)
           End If
         Next
'*****************
         'Daten nach Spalte E aufsteigend, dann H absteigend sortieren
        .Range(.Cells(1, 1), .Cells(zt1 + 1 + bis - von, 15)).Sort _
         key1:=.Range("E1"), Order1:=xlAscending, _
        key2:=.Range("H1"), 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
Schöne Grüße,
Michael

Bild

Betrifft: AW: So?
von: Jenny
Geschrieben am: 10.07.2015 22:16:47
Hallo Michael,
habe leider Besuch hier, werde erst morgen im Laufe des Tages dazu kommen, es zu testen.
Ich melde mich und danke schonmal
Jenny

Bild

Betrifft: AW: So?
von: Jenny
Geschrieben am: 11.07.2015 14:24:17
Hallo Michael,
da bin ich wieder, danke für die Geduld,
ich weiß nicht obs an meinen oder deinen Änderungen liegt, jedoch wird der Text der aus den Tabellen 2 und 3 in Tabelle1 eingefügt wird eine Zeile zu weit unten eingefügt, kannst du mal schaun ob du was machen kannst, dass er eine Zeile weiter oben eingefügt wird?
Das mit Spalte F funktioniert.
LG
Jenny

Bild

Betrifft: AW: So?
von: Jenny
Geschrieben am: 11.07.2015 14:26:14
ok, hat das was mit deinem zt1 + 1 zu tun?

Bild

Betrifft: AW: So?
von: Jenny
Geschrieben am: 11.07.2015 15:00:26
Ja gut das +1 hab ich wieder rausgenommen,
aber ein anderes Problem hab ich jetzt lade mal nochmal eine Datei hoch,
das Makro kann nicht vernünftig nach Spalte E und dann H sortieren, da um die ganze Tabelle zu sortieren Einträge in Spalte E fehlen.
Ist es denn möglich, dass das Makro die Formel die in E1 steht auch bis zum Ende des Textes kopiert?
Am besten auch wenn ich es nicht fürs sortieren brauche auch die Formel in Spalte D?
VG
Jenny
https://www.herber.de/bbs/user/98770.xlsm

Bild

Betrifft: AW: So?
von: Michael
Geschrieben am: 11.07.2015 16:08:33
Hi Jenny,
füge diese Zeilen zwischen den *** bitte vor das For Each c ein:

'***************** neu am 11.07. **********
 Range(.Cells(zt1 - 1, 4), .Cells(zt1 - 1, 5)).Copy _
 Sheets("Tabelle1").Range(Cells(zt1, 4), Cells(zt1 + bis - von + 1, 4))
 ' Stop
 '***************** neu am 11.07. **********
 
Damit werden die Formeln in D und E kopiert, aber glücklich machen wird Dich das auch nicht, denn D greift auf die Spalte O zu, und dort kopiert Dein Makro keine Werte hin.
Ich verstehe die Formel in D sowieso nicht: sie ergibt ein Datum, und O ist auch ein Datum, wobei nur die Anzeige anders formatiert ist.
Schöne Grüße,
Michael

Bild

Betrifft: AW: So?
von: Jenny
Geschrieben am: 11.07.2015 16:29:50
genau das ist ja der Sinn der Formel in Spalte D, dass da ein Datum steht, mit dem Excel rechnen kann, das kann es mit dem in Spalte O nicht, Spalte O ist allerdings meine Quelle aus dem internet.
Die Formeln in den Spalten I bis N auch wenn sie teilweise in der Bsp.-Datei fehlen, sind alle in irgendeiner Weise von E abhängig.
Die Formel in Spalte D lässt die Zelle leer, wenn O leer ist, somit kann E trotzdem ein Maximum berechnen.
Ich werds dann mal testen.

Bild

Betrifft: AW: So?
von: Jenny
Geschrieben am: 11.07.2015 16:41:18
wie meinst du das genau, wo ichs hintun soll
das folgende Makro produziert einen Fehler 400


Sub Makro1()
      Dim zt1&, von&, bis As Long
      Dim Grafiken As Shape
 '*****************
      Dim c As Range, a As Variant
 '*****************
      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, 7)
          End With
          With Sheets("Tabelle3")
              'Inhalt aus Spalte E kopieren
              .Range(.Cells(von, 5), .Cells(bis, 5)).Copy
          End With
          'In Spalte H einfügen
          .Cells(zt1, 8).PasteSpecial Paste:=xlPasteValues
          Application.CutCopyMode = False
         If bis > 1 Then
           'Spalte A bis C 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
          
        Range(.Cells(zt1 - 1, 4), .Cells(zt1 - 1, 5)).Copy _
        Sheets("Tabelle1").Range(Cells(zt1, 4), Cells(zt1 + bis - von + 1, 4))
          
 '         Stop
 '*****************
          For Each c In Range(.Cells(zt1, 7), .Cells(zt1 + bis - von + 1, 7))
            If c.Hyperlinks.Count > 0 Then
               a = Split(c.Hyperlinks(1).Address, "/")
 '              For i = 1 To UBound(a): MsgBox a(i): Next
               c.Offset(0, -1).Value = a(UBound(a) - 1)
            End If
          Next
 '*****************
          'Daten nach Spalte E aufsteigend, dann H absteigend sortieren
         .Range(.Cells(1, 1), .Cells(zt1 + 1 + bis - von, 15)).Sort _
          key1:=.Range("E1"), Order1:=xlAscending, _
         key2:=.Range("H1"), 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
 


Bild

Betrifft: AW: So?
von: Michael
Geschrieben am: 11.07.2015 18:09:46
Ja, so war es schon gemeint, aber ich habe Deine letzte Datei nochmal runtergeladen, das komplette Ding reinkopiert und getestet: bei mir kommt kein Fehler.
Hm, hm, hm, ich stelle die komplette Datei mal rein: https://www.herber.de/bbs/user/98773.xlsm
Beim testhalben Download der Datei habe ich gesehen, daß eine Zelle zu tief kopiert wird; also nimm bitte in der Zeile mit dem Cells(zt1 + bis - von + 1, 4)) das +1 raus.
Schöne Grüße,
Michael

Bild

Betrifft: AW: So?
von: Jenny
Geschrieben am: 11.07.2015 20:27:20
Hallo Michael,
ich verstehs nicht mehr, habe jetzt deine Datei geöffnet da hats funktioniert.
Hab jetzt das Makro aus deiner Datei in meine kopiert und siehe da es ging auch, keine Ahnung was vorher los war.
LG und vielen Dank
für die viele Mühe
Jenny
PS Im moment fällt mir nichts auf, was nicht funktioniert also damit Thema abgeschlossen.

Bild

Betrifft: AW: So?
von: Jenny
Geschrieben am: 11.07.2015 22:01:11
Hallo Michael,
leider tritt doch der Fehler 400 auf, auch in deiner mir zugesendeten Datei.
Das erste mal lässt sich das Makro ausführen, wenn ich dann jedoch im Bereich A384:C384 neuen Text einfüge sowie erneut Inhalt in Tabelle 2 und 3 und dann das Makro neu ausführe kommt der Fehler 400
er füllt noch die Spalten A bis C auf, dann bricht er ab.
Das interessante ist dann, wenn ich alles was das Makro gemacht hat wieder lösche, die Mappe also wieder den zustand hat bevor ich das Makro ausgeführt habe, die Mappe speichere, schließe und wieder öffne lässt es sich ausführen. Jedoch immer schließen und wieder öffnen ist auch blöd.
Dir da jetzt ein Bsp. zu schicken ist schwer, weil dadurch die Datei geschlossen und wieder geöffnet wird, es also bei dir funktionieren wird.
LG
Jenny

Bild

Betrifft: AW: So?
von: Jenny
Geschrieben am: 11.07.2015 22:42:27
hab das Problem weiter eingrenzen zu können, es hat nichts mit dem erneuten Ausführen oder Excel neu starten zu tun.
Das Makro lässt sich ausführen, wenn die Tabelle 1 beim starten des Makros aktiv ist, wenn eine der anderen 3 Tabellen aktiv ist, kommt Fehler 400.
Lässt sich das umgehen?

Bild

Betrifft: AW: So?
von: Silent_Warrior5
Geschrieben am: 12.07.2015 10:55:50
Hi, du musst deinem Makro genau sagen wo es was machen soll, hab mir den Code nich genau angeschaut aber z.b. hier:
Range(.Cells(zt1 - 1, 4), .Cells(zt1 - 1, 5)).Copy
würde ich den name aus dem VBA Explorer Dabei bauen z.b. Blatt heist "Hallo" aber im VBA Editor steht tabelle1 (Hallo).
Dann mach einfach so:
tabelle1.Range(.Cells(zt1 - 1, 4), .Cells(zt1 - 1, 5)).Copy
Geh einfach den Code durch und schau ob dein Makro imma weis wo es was machen muss auch wenn du eine andere Tabelle aktiv hast. Und nicht nur die wo er was machen soll. Auch With and End With hilft bei sowas wie ihr ja unten auch benutzt.
Gruß
SW5

Bild

Betrifft: AW: So?
von: Jenny
Geschrieben am: 12.07.2015 12:01:52
Hallo SW5,
jetzt hab ich probiert, es analog zu dem kopieren obendrüber zu machen, hab with und end with eingefügt,
jetzt kommt ein Laufzeitfehler 1004 statt dem 400 Fehler
und diese Zeilen werden markiert beim Debug:

          Range(.Cells(zt1 - 1, 4), .Cells(zt1 - 1, 5)).Copy _
          Destination:=.Range(Cells(zt1, 4), Cells(zt1 + bis - von, 4))
Sub Makro3()
'
' Makro3 Makro
'
' Tastenkombination: Strg+i
'
      Dim zt1&, von&, bis As Long
      Dim Grafiken As Shape
 '*****************
      Dim c As Range, a As Variant
 '*****************
      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, 7)
          End With
          With Sheets("Tabelle3")
              'Inhalt aus Spalte E kopieren
              .Range(.Cells(von, 5), .Cells(bis, 5)).Copy
          End With
          'In Spalte H einfügen
          .Cells(zt1, 8).PasteSpecial Paste:=xlPasteValues
          Application.CutCopyMode = False
         If bis > 1 Then
           'Spalte A bis C 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
          With Sheets("Tabelle1")
          Range(.Cells(zt1 - 1, 4), .Cells(zt1 - 1, 5)).Copy _
          Destination:=.Range(Cells(zt1, 4), Cells(zt1 + bis - von, 4))
          Application.CutCopyMode = False
          End With
 '         Stop
 '*****************
          For Each c In Range(.Cells(zt1, 7), .Cells(zt1 + bis - von, 7))
            If c.Hyperlinks.Count > 0 Then
               a = Split(c.Hyperlinks(1).Address, "/")
 '              For i = 1 To UBound(a): MsgBox a(i): Next
               c.Offset(0, -1).Value = a(UBound(a) - 1)
            End If
          Next
 '*****************
          'Daten nach Spalte E aufsteigend, dann H absteigend sortieren
         .Range(.Cells(1, 1), .Cells(zt1 + 1 + bis - von, 15)).Sort _
          key1:=.Range("E1"), Order1:=xlAscending, _
         key2:=.Range("H1"), 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


Bild

Betrifft: AW: So?
von: Silent_Warrior5
Geschrieben am: 12.07.2015 13:32:13
Hi schreib nomma genau was du willst. und ich guck schnell nach. Gruß SW5

Bild

Betrifft: AW: So?
von: Jenny
Geschrieben am: 12.07.2015 13:34:02
bavor ich genau diese beiden Zeilen eingefügt habe, ließ sich das Makro von jedem Blatt aus starten, jetzt nur noch von Tabelle1 aus, sonst LZF 1004.

Bild

Betrifft: AW: So?
von: Silent_Warrior5
Geschrieben am: 12.07.2015 14:46:15
Hi so hab was ausgebessert. Wer ist eigentlich Christian? Wäre auch klug seine Datenverbindungen zu löschen bevor man eine Mappe als Beispiel hochläd.
So nun kannste das Makro auch von z.b. Tabelle4 ausführen. Schau ob es das richtige macht.
Den Fehler haste bekommen weil du nen Makro in nen Modul machen sollst wenn du es von andern Tabellenblättern ausführen willst.
https://www.herber.de/bbs/user/98780.xlsm
Gruß
SW5

Bild

Betrifft: AW: So?
von: Jenny
Geschrieben am: 12.07.2015 15:55:29
Wer Christian ist?
Mein Mann, wir teilen uns das Laptop und einen Bentzernamen hier. Also ich schließe mal nicht aus, dass da auch mal irgendwo sein Name auftauchen kann.
Aber nun zu deiner Datei,
was eigentlich nicht hätte passieren sollen, ist dass Tabelle 1 Zeile 1 entsteht, die ist zuviel. Ansonsten pasts, der Fehler kommt nicht mehr.
LG
Jenny

Bild

Betrifft: AW: So?
von: Silent_Warrior5
Geschrieben am: 12.07.2015 16:12:21
Hi, das liegt nicht an meiner Veränderung. Mach doch einfach Überschriften dort drüber. Hätt ich sowieso gemacht und dann sollte es ja passen oder?
Gruß
SW5

Bild

Betrifft: AW: So?
von: Michael
Geschrieben am: 12.07.2015 16:28:46
Hi zusammen,
das mit "neuen Daten" konnte ich natürlich bei mir schlecht testen...
Ich bin ja froh, daß es mit vereinter Hilfe nun doch klappt!
Happy Exceling,
Michael

Bild

Betrifft: AW: So?
von: Jenny
Geschrieben am: 12.07.2015 16:37:44
Hallo ihr beiden,
das Problem ist, dass der Inhalt von Spalten D und E eine Zeile zu weit kopiert wird, und die Zeile landet dann durchs sortieren ganz oben.
VG
Jenny

Bild

Betrifft: AW: So?
von: Jenny
Geschrieben am: 12.07.2015 16:40:27
Hallo ihr beiden,
das Problem ist, dass der Inhalt von Spalten D und E eine Zeile zu weit kopiert wird, und die Zeile landet dann durchs sortieren ganz oben.
VG
Jenny

Bild

Betrifft: AW: So?
von: Jenny
Geschrieben am: 12.07.2015 16:42:04
So hab jetzt in der Zeile

Sheets("Tabelle1").Range("D" & zt1 & ":E" & zt1 + bis - von + 1)
das +1 rausgenommen, jetzt klappts.
Danke euch beiden für die Mühe und die viele Geduld.
Jenny

Bild

Betrifft: AW: So?
von: Jenny
Geschrieben am: 12.07.2015 16:43:49
hallo Michael,
das mit den neuen Daten war nur eine Vermutung von mir, offensichtlich lags daran dass das Makro bei mir unter "Diese Arbeitsmappe" statt einem Modul lag.
Jenny

Bild

Betrifft: So!
von: Michael
Geschrieben am: 12.07.2015 17:12:29
Hi Jenny,
sorry, ich hatte mich schon gewundert, aber vor lauter Dings versäumt, Dich darauf aufmerksam zu machen.
Na denn,
Gruß, Michael

Bild

Betrifft: AW: So!
von: Jenny
Geschrieben am: 12.07.2015 18:10:27
Naja,
bei der Mühe die ihr euch gegeben habt, kann man das verzeihen, also kein Ding.
Schönen Sonntag noch
Jenny

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Hyperlinks per Makro auslesen"