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!!!
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 Nutzer sagt Danke an Kuwer für diesen Beitrag:
  • sharky51
Top
#3
Hallo Uwe,

cool, vielen Dank funktioniert perfekt!
Top


Gehe zu:


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