Hyperlink-Adressen in die Zwischenablage kopieren?

Selma · 2016-12-31T12:03:39+00:00

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

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

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

Hyperlink-Adressen in die Zwischenablage kopieren?

Forumthread: Hyperlink-Adressen in die Zwischenablage kopieren?

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Hyperlink-Adressen in die Zwischenablage kopieren?

Forumthread: Hyperlink-Adressen in die Zwischenablage kopieren?

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

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread