Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

Excel vba Hyperlinks mitkopieren
#1
Hallo zusammen,

aus dem Netz habe ich einen vba-Code der eine Liste von Links in Spalte "B" in mehrere Blätter in derselben Mappe aufteilt.
Es wird aber leider nur die Linkbezeichnung kopiert und nicht der ausführbare Link.
Beim Umkopieren soll aber der ausführbare Link umkopiert werden.

Hier der das Beispiel:
Code:
'https://www.herber.de/forum/archiv/1360to1364/1362808_VBA__Liste_auf_mehrere_Blaetter_verteilen.html
'Liste auf mehrere Blätter verteilen
Sub Aufteilen()
Dim ArWerte(), oDic As Object, rng As Range, rngFilter As Range
Dim n&

Events_ False

With Tabelle1 'Datentabelle
    Set rng = .UsedRange.Resize(, .UsedRange.Columns.Count + 1)
    ArWerte = .Range("D2", .Cells(.Rows.Count, 4).End(xlUp))
    Set oDic = CreateObject("Scripting.Dictionary")
    For n = 1 To UBound(ArWerte)
        oDic(ArWerte(n, 1)) = 0
    Next n
    ArWerte = oDic.keys
    QuickSort ArWerte, LBound(ArWerte), UBound(ArWerte)
    With ThisWorkbook
        Set rngFilter = rng.Cells(1, rng.Columns.Count).Resize(2, 1)
        rngFilter.NumberFormat = "General"
        For n = LBound(ArWerte) To UBound(ArWerte)
            CheckTab_And_Kill ArWerte(n)
            With Sheets.Add(After:=.Sheets(.Sheets.Count), Type:=xlWorksheet)
                .Name = ArWerte(n)
                rngFilter.Cells(2, 1).FormulaR1C1 = "=RC4=" & IIf(IsNumeric(ArWerte(n)), ArWerte(n), Chr(34) & ArWerte(n) & Chr(34))
                rngFilter.Calculate
                rng.AdvancedFilter xlFilterCopy, rngFilter, .Cells(1, 1)
                .UsedRange.EntireColumn.AutoFit
            End With
            rngFilter.Clear
        Next n
    End With
End With
Events_ True
End Sub

Sub CheckTab_And_Kill(ByVal strTabName$)
Dim oSH As Object
On Error Resume Next
Set oSH = ThisWorkbook.Sheets(strTabName)
If Not oSH Is Nothing Then oSH.Delete
End Sub

Sub Events_(booSchalter As Boolean)
With Application
    .EnableEvents = booSchalter
    .DisplayAlerts = booSchalter
    .ScreenUpdating = booSchalter
End With
End Sub

Sub QuickSort(ByRef sArray As Variant, ByVal MinElem As Long, MaxElem As Long)
Dim Mitte As Long
Dim vDummy As Variant
Dim i As Long, j As Long
    If MinElem > MaxElem Then
        Exit Sub
    End If

    Mitte = (MinElem + MaxElem) \ 2

    i = MinElem
    j = MaxElem
    Do
        Do While sArray(i) < sArray(Mitte)
            i = i + 1
        Loop
        Do While sArray(j) > sArray(Mitte)
            j = j - 1
        Loop
        If i <= j Then
            vDummy = sArray(j)
            sArray(j) = sArray(i)
            sArray(i) = vDummy
            i = i + 1
            j = j - 1
        End If
    Loop Until i > j
    QuickSort sArray, MinElem, j
    QuickSort sArray, i, MaxElem
End Sub

Wie müsste der vba-Code erweitert werden, um den jeweiligen ausführbaren Link der kopierten Zellen mit in die neue Tabelle mit zu kopieren?

Habe nicht erwähnt dass das o.g. Makro von Tino kam! Sorry!!!
Mit freundlichen Grüßen / Best regards
                          //
----------o00o---°(_)°---o00o----------------------

Erich
Antwortento top
#2
Hallo Erich,
            With Sheets.Add(After:=.Sheets(.Sheets.Count), Type:=xlWorksheet)
.Name = ArWerte(n)
rngFilter.Cells(2, 1).FormulaR1C1 = "=RC4=" & IIf(IsNumeric(ArWerte(n)), ArWerte(n), Chr(34) & ArWerte(n) & Chr(34))
rngFilter.Calculate
'rng.AdvancedFilter xlFilterCopy, rngFilter, .Cells(1, 1)
rng.AdvancedFilter xlFilterInPlace, rngFilter
rng.Copy .Cells(1)
.UsedRange.EntireColumn.AutoFit
End With
Gruß Uwe
[-] Folgende(r) 1 Benutzer sagt Danke an Kuwer für diesen Beitrag:
  • sharky51
Antwortento top
#3
Hallo Uwe,

cool, vielen Dank funktioniert perfekt!
Mit freundlichen Grüßen / Best regards
                          //
----------o00o---°(_)°---o00o----------------------

Erich
Antwortento top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste