Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Hyperlink-Adressen in die Zwischenablage kopieren?

Hyperlink-Adressen in die Zwischenablage kopieren?
31.12.2016 12:03:39
Selma
Hallo Leute,
ist es möglich per VBA nur für die markierten Zellen die Hyperlink-Adressen in die Zwischenablage zu speichern?
Meine Hyperlinks sind über die Formeln =HYPERLINK... aufgebaut. Im Anhang habe ich eine Beispieldatei beigefügt: https://www.herber.de/bbs/user/110272.xls
Die Hyperlink-Adressen möchte ich nachher in einer Textdatei untereinander einfügen.
Besten Dank im Voraus!
Gruß,
Selma

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Das würde dann angepasst...
31.12.2016 15:30:22
Case
Hallo Selma, :-)
... so gehen: ;-)
Option Explicit
Sub Main()
Dim objClipBoard As Object
Dim strTMP As String
Dim objCell As Range
On Error GoTo Fin
If TypeOf Selection Is Range Then
For Each objCell In Selection
strTMP = strTMP & Cells(objCell.Row, objCell.Column - 1).Text & _
Split(Split(Cells(objCell.Row, objCell.Column).Formula, _
"&""")(1), """,")(0) & vbCrLf
Next objCell
End If
If strTMP  vbNullString Then
strTMP = Left$(strTMP, Len(strTMP) - 1)
Set objClipBoard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Call objClipBoard.SetText(strTMP)
Call objClipBoard.PutInClipboard
End If
Set objClipBoard = Nothing
If Err.Number  0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub
Servus
Case

Anzeige
Nachtrag...
31.12.2016 15:33:06
Case
Hallo Selma, :-)
... ich gehe jetzt feiern - Fehler korrigiert: ;-)
Option Explicit
Sub Main()
Dim objClipBoard As Object
Dim strTMP As String
Dim objCell As Range
On Error GoTo Fin
If TypeOf Selection Is Range Then
For Each objCell In Selection
strTMP = strTMP & Cells(objCell.Row, objCell.Column - 1).Text & _
Split(Split(Cells(objCell.Row, objCell.Column).Formula, _
"&""")(1), """,")(0) & vbCrLf
Next objCell
End If
If strTMP  vbNullString Then
strTMP = Left$(strTMP, Len(strTMP) - 1)
Set objClipBoard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Call objClipBoard.SetText(strTMP)
Call objClipBoard.PutInClipboard
End If
Fin:
Set objClipBoard = Nothing
If Err.Number  0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub
Servus
Case

Anzeige
AW: Nachtrag...
31.12.2016 17:41:18
Selma
Hallo Ralf,
vielen Dank fürs Makro. Es funktioniert, aber :-) wenn ich die Daten aus der Spalte C z.B. um eine Spalte nach links verschiebe, dann muss ich es im Code ... -2 eintragen bzw. anpassen.
Da ich das Makro für andere Spalten auch nutzen, wäre es besser, wenn der Hyperlink aus der Formel (wie in meiner Beispieldatei dargestellt) genommen werden könnte. Dann brauche ich nicht das Makro jedes Mal anpassen. Geht das bitte?
Viele Grüße,
Selma
Na dann machen wir es...
01.01.2017 00:52:50
Case
Hallo Selma, :-)
... doch so: ;-)
Option Explicit
Sub Main()
Dim objClipBoard As Object
Dim strTMP1 As String
Dim strTMP As String
Dim objCell As Range
On Error GoTo Fin
If TypeOf Selection Is Range Then
For Each objCell In Selection
strTMP1 = Range(Split(Split(Cells(objCell.Row, objCell.Column).Formula, _
"($")(1), "=")(0)).Text
strTMP = strTMP & strTMP1 & Split(Split(Cells(objCell.Row, _
objCell.Column).Formula, "&""")(1), """,")(0) & vbCrLf
Next objCell
End If
If strTMP  vbNullString Then
strTMP = Left$(strTMP, Len(strTMP) - 1)
Set objClipBoard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Call objClipBoard.SetText(strTMP)
Call objClipBoard.PutInClipboard
End If
Fin:
Set objClipBoard = Nothing
If Err.Number  0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub
Hoffe, dass ich mit 3,8 auf dem Kessel nichts vergessen habe. ;-)
Gutes Neues übrigens. ;-)
Servus
Case

Anzeige
Ergänzung...
01.01.2017 15:32:59
Selma
Hallo Ralf,
ich wünsche Dir ein gesundes Neues Jahr. Trotz 3,8 auf dem Kessel hat es gepasst ;-)
Wie kann ich die Zwischenablage um Änderungsdatum (YYYY-MM-DD hh:mm) des Hypelinkdatei / Ordner erweitern?
Ausgabe in der Zwischenablage:
Änderungsdatum;Hyperlinkadresse
Bsp:
2016-15-31 22:05;C:\Daten\Projekte\2016
2016-05-11 12:48;C:\Daten\Projekte\2016\25000800\text.txt
Gruß,
Selma
Bei Ordner und Dateien...
01.01.2017 19:57:18
Case
Hallo Selma, :-)
... dann so: ;-)
Option Explicit
Sub Main()
Dim objClipBoard As Object
Dim strTMP1 As String
Dim strTMP2 As String
Dim strTMP3 As String
Dim objCell As Range
On Error GoTo Fin
If TypeOf Selection Is Range Then
For Each objCell In Selection
strTMP1 = Range(Split(Split(Cells(objCell.Row, objCell.Column).Formula, _
"($")(1), "=")(0)).Text
strTMP2 = strTMP1 & Split(Split(Cells(objCell.Row, _
objCell.Column).Formula, "&""")(1), """,")(0)
strTMP3 = strTMP3 & fncLast(strTMP2) & ";" & strTMP2 & vbCrLf
Next objCell
End If
If strTMP3  vbNullString Then
strTMP3 = Left$(strTMP3, Len(strTMP3) - 1)
Set objClipBoard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Call objClipBoard.SetText(strTMP3)
Call objClipBoard.PutInClipboard
End If
Fin:
Set objClipBoard = Nothing
If Err.Number  0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub
Private Function fncLast(ByVal strTMP As String) As String
If (GetAttr(strTMP) = vbDirectory) Then
fncLast = fncLastD(strTMP)
Else
fncLast = Format(FileDateTime(strTMP), "YYYY-MM-DD")
End If
End Function
Private Function fncLastD(ByVal strTMP As String) As String
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject").GetFolder(strTMP)
fncLastD = Format(objFSO.DateLastModified, "YYYY-MM-DD")
Set objFSO = Nothing
End Function
Getestet trotz Kater. ;-)
Servus
Case

Anzeige
AW: Bei Ordner und Dateien...
01.01.2017 20:26:59
Selma
"Getestet trotz Kater" :-))
Es passt! Vielen Dank!
AW: Bei Ordner und Dateien...
01.01.2017 20:42:11
Selma
Es wird Erstellungdatum anstatt Änderungsdatum ausgelesen.
Bei allen Tests...
01.01.2017 22:57:26
Case
Hallo Selma, :-)
... bei mir nicht. Mein "Temp-Ordner" z. B. gab bei dem Test...
ShowDateCreated = 19.08.2016 08:12:37
ShowLastAccess = 01.01.2017 18:27:05
ShowLastModified = 01.01.2017 18:27:05
... aus.
Gleiches Ergebnis auch mit "CreateObject("Shell.Application")" - "Debug.Print folder.self.modifydate".
Mehr kann ich im Moment nicht dazu sagen. ;-)
Servus
Case

Anzeige

312 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige