18.05.2020, 10:44
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:
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!!!
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 SubWie 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!!!