Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1348to1352
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Hyperlinks kopieren

Hyperlinks kopieren
18.02.2014 17:30:25
klaus
Hallo zusammen
Aus dem Sheet mit den Hyperlinks gehen Hauptprojekte (1) und zugeordnete Subprojekte (2) hervor. Das VBA-Programm soll nun die Hauptprojeke finden, die Subprojekte haben und deren Sheets den Hyperlink zu den jeweiligen Subprojekten reinkopieren. So soll z.B. das Hauptprojekt „Dos_A1-G80-NW“ mit den drei folgenden Subprojekten (Zelle A4 bis A6) eine Kopie des jeweiligen Hyperlinks im gleichnamigen Sheet „Dos_A1-G80-NW“ in den Zellen B2 bis D2 haben.
Userbild
Der bisherige Code sieht wie folgt aus:

Sub LinkvonHzuSProjekt()
Dim Sp As Integer
Set wks = Worksheets(sDos)
Ze = 2
Sp = 3
Do While Not IsEmpty(wks.Cells(Ze, 1))
strHP = Left(wks.Cells(Ze, 1).Formula, 12)
If strHP = Left(wks.Cells(Ze, 1).Offset(1, 0).Formula, 12) Then
wks.Cells(1, Sp).Copy
'Ziel ist das jeweilige Sheet, des Hauptprojektes
End If
Ze = Ze + 1
Loop
End Sub

Ihr habt die bestimmte Ideen. Freue mich auf eine Antwort
Klaus.

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Hyperlinks kopieren
19.02.2014 10:52:48
fcs
Hallo Klaus,
hier mein Vorschlag.
Gruß
Franz
Sub LinkvonHzuSProjekt()
Dim Ze As Long, Sp As Long
Dim strHP, Zeile_A As Long, Spalte_Z As Long
Dim wks As Worksheet
Const Zeile_Z = 2 'Zeile für Links in Zielblatt
Const Spalte_Z1 = 2 '1. Spalte für Link in Zielblatt
'Const sDos = "AA" 'Testzeile
Set wks = Worksheets(sDos)
Ze = 2  '1. Zeile mit Link zu Hauptprojekt
Sp = 1 'Spalte mit Hyperlinks
Spalte_Z = Spalte_Z1
strHP = Left(wks.Cells(Ze, Sp).Text, 12)
Ze = Ze + 1
Do While Not IsEmpty(wks.Cells(Ze, Sp))
If strHP  Left(wks.Cells(Ze, Sp).Text, 12) Then
Spalte_Z = Spalte_Z1
strHP = Left(wks.Cells(Ze, Sp).Text, 12)
Else
'Unter-Projekt-Link kopieren
wks.Cells(Ze, Sp).Copy Destination:=Worksheets(strHP).Cells(Zeile_Z, Spalte_Z)
Spalte_Z = Spalte_Z + 1
End If
Ze = Ze + 1
Loop
End Sub

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige