Anzeige
Archiv - Navigation
1776to1780
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

Hyperlink übernehmen

Hyperlink übernehmen
21.08.2020 10:39:22
Jan
Ich bin absoluter Anfänger und habe ein Problem mit einem bestehenden VBA-Code
Beschreibung: Das Programm kopiert Daten von verschiedenen Datenblättern in ein anderes Datenblatt (Zusammenfassung). Unter anderem befinden sich darunter auch Hyperlinks.
Problem: Die Hyperlinks werden nur als Text kopiert, wobei der Hyperlink nicht automatisch mitkopiert wird. Wie kann man das lösen? ich kann euch leider nicht sagen, wo im Code das Problem liegt, weswegen ich den ganzen Code einfügen muss. Ich hoffe ihr könnt mir trotzdem weiterhelfen.
Vielen Dank
Freundliche Grüsse
Sub Aktualisieren()
'Alle Rubriken weredn in der Zusammenfassung aktualisiert
Dim cRubrik As New Collection
Dim vBlatt As Variant
cRubrik.Add Worksheets("Reklamation")
cRubrik.Add Worksheets("PROZESSABWEICHUNG")
cRubrik.Add Worksheets("Lieferantenmanagement")
cRubrik.Add Worksheets("KVP")
cRubrik.Add Worksheets("Wissensmanagement")
cRubrik.Add Worksheets("AUDIT")
Dim i As Long
For i = 1 To cRubrik.Count
Rubrik_Aktualisieren cRubrik(i)
Next i
'    For Each vBlatt In cRubrik
'        Debug.Print vBlatt.Name
'        Rubrik_Aktualisieren vBlatt
'    Next vBlatt
End Sub
Sub Rubrik_Aktualisieren(ByRef wsRubrik As Worksheet)
'Die pendent-Eintrtäge im wsRubrik-Blatt werden in das "Zusammenfassung"-Blatt übertragen
Dim rZBereich       As Range        'Bereich im "Zusammenfassung"-Blatt
Dim rRBereich       As Range        'Bereich im Rubrik-Blatt
Dim lZZeile         As Long         'Aktuelle Zeile im "Zusammenfassung"-Blatt
Dim lRZeile         As Long         'Aktuelle Zeile im im Rubrik-Blatt
Dim lZSpalte        As Long         'Aktuelle Spalte im "Zusammenfassung"-Blatt
Dim rFundzelle      As Range        'Gefundene Zelle im im Rubrik-Blatt
Dim lRCheckSpalte   As Long         'Spaltennummer der "pendent"-Spalte
Dim vSpaltenindex
Dim vRubrik
Dim vZusammenfassung
'Im "Zusammenfassung"-Blatt Spalte A wird die Überschrift wsRubrik gesucht
With Worksheets("ZUSAMMENFASSUNG")
For Each rZBereich In .Range(.Range("A1"), .Cells(.Rows.Count, 1).End(xlUp))
If StrComp(rZBereich, wsRubrik.Name, vbTextCompare) = 0 And rZBereich.Font. _
ColorIndex = .Range("A1").Font.ColorIndex Then Exit For
Next rZBereich
End With
If rZBereich Is Nothing Then Exit 

Sub             'Abbruch, wenn keine passsende Überschrift gefunden wurde
'Kopfzeile des entsprechenden Abschnitts im "Zusammenfassung"-Blatt wird definiert
With Worksheets("ZUSAMMENFASSUNG")
Set rZBereich = Range(rZBereich.End(xlDown), .Cells(rZBereich.End(xlDown).Row, .Columns. _
Count).End(xlToLeft))
End With
ReDim vSpaltenindex(1 To rZBereich.Columns.Count)
ReDim vZusammenfassung(1 To UBound(vSpaltenindex), 1 To 1)
'Im Rubrik-Blatt wird der zu durchsuchende Bereich festgelegt
With wsRubrik
Set rRBereich = .Range("A6")
Set rRBereich = Range(rRBereich, .Cells(.Cells(.Rows.Count, rRBereich.Column).End(xlUp). _
Row, .Cells(rRBereich.Row, .Columns.Count).End(xlToLeft).Column))
End With
vRubrik = rRBereich
'Spaltenindices
For lZSpalte = 1 To UBound(vSpaltenindex)
Set rFundzelle = rRBereich.Rows(1).Find(rZBereich(lZSpalte), lookat:=xlWhole)
If Not rFundzelle Is Nothing Then                       'wurde gefunden
vSpaltenindex(lZSpalte) = rFundzelle.Column
End If
Next lZSpalte
'Spalte "pendent" wird festgestellt
Set rFundzelle = rRBereich.Rows(1).Find("Kontrolle Vorgang und Ablage vollständig,  _
Archivierung", lookat:=xlPart)
If Not rFundzelle Is Nothing Then
lRCheckSpalte = rFundzelle.Column
'Im Rubrik-Blatt wird Zeile für Zeile durchlaufen
For lRZeile = 2 To UBound(vRubrik, 1)
If vRubrik(lRZeile, lRCheckSpalte) = "pendent" Then
For lZSpalte = 1 To UBound(vZusammenfassung, 1)
If vSpaltenindex(lZSpalte) Then vZusammenfassung(lZSpalte, UBound( _
vZusammenfassung, 2)) = vRubrik(lRZeile, vSpaltenindex(lZSpalte))
Next lZSpalte
ReDim Preserve vZusammenfassung(1 To UBound(vZusammenfassung, 1), 1 To UBound( _
vZusammenfassung, 2) + 1)
End If
Next lRZeile                'Nächste Zeile im Rubrik-Blatt
End If
'Platz schaffen für neue Rubrik-Zeilen und einfügen
With Worksheets("ZUSAMMENFASSUNG")
If rZBereich.CurrentRegion.Rows.Count > UBound(vZusammenfassung, 2) Then
Range(.Cells(rZBereich.Row + UBound(vZusammenfassung, 2), 1), .Cells(rZBereich.Row + _
rZBereich.CurrentRegion.Rows.Count - 1, 1)).EntireRow.Delete
ElseIf rZBereich.CurrentRegion.Rows.Count 
Sub Zufall()
Application.EnableEvents = False
Dim cRubrik As New Collection
Dim rRBereich       As Range        'Bereich im Rubrik-Blatt
Dim lRZeile         As Long         'Aktuelle Zeile im im Rubrik-Blatt
Dim rFundzelle      As Range        'Gefundene Zelle im im Rubrik-Blatt
Dim lRCheckSpalte   As Long         'Spaltennummer der "pendent"-Spalte
Randomize Timer
cRubrik.Add Worksheets("Reklamation")
cRubrik.Add Worksheets("PROZESSABWEICHUNG")
cRubrik.Add Worksheets("Lieferantenmanagement")
cRubrik.Add Worksheets("KVP")
cRubrik.Add Worksheets("Wissensmanagement")
cRubrik.Add Worksheets("AUDIT")
Dim i As Long
For i = 1 To cRubrik.Count
With cRubrik(i)
.Activate
'Im Rubrik-Blatt wird der zu durchsuchende Bereich festgelegt
Set rRBereich = .Range("A6")
Set rRBereich = Range(rRBereich, .Cells(.Cells(.Rows.Count, rRBereich.Column).End( _
xlUp).Row, .Cells(rRBereich.Row, .Columns.Count).End(xlToLeft).Column))
End With
'Spalte "pendent" wird festgestellt
Set rFundzelle = rRBereich.Rows(1).Find("Kontrolle Vorgang und Ablage vollständig,  _
Archivierung", lookat:=xlPart)
If rFundzelle Is Nothing Then                       'wurde nicht gefunden
cRubrik(i).Activate
MsgBox "Achtung! " & vbCr & "Kontrollspalte im " & vbCr & _
"Blatt """ & cRubrik(i).Name & """ nicht gefunden. " & vbCr & "Kein Eintrag  _
in dieser Rubrik. "
Else                                                'wurde gefunden
lRCheckSpalte = rFundzelle.Column
'Im Rubrik-Blatt wird Zeile für Zeile durchlaufen
For lRZeile = 2 To rRBereich.Rows.Count
If Rnd > 0.2 Then
rRBereich(lRZeile, lRCheckSpalte) = "pendent"
Else
rRBereich(lRZeile, lRCheckSpalte) = "erledigt"
End If
Next lRZeile                'Nächste Zeile im Rubrik-Blatt
End If
Next i
Application.EnableEvents = True
End Sub

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Crosspost ohne Hinweis
21.08.2020 10:49:07
Werner
Hallo,
würdest du bitte die Beiträge in den verschiedenen Foren untereinander verlinken.
Gruß Werner
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige