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 < UBound(vZusammenfassung, 2) Then
Range(.Cells(rZBereich.Row + rZBereich.CurrentRegion.Rows.Count, 2), .Cells(rZBereich.Row + UBound(vZusammenfassung, 2) - 1, 2)).EntireRow.Insert CopyOrigin:=xlFormatFromRightOrBelow
End If
rZBereich.Offset(1).Resize(UBound(vZusammenfassung, 2), UBound(vZusammenfassung, 1)) = Application.WorksheetFunction.Transpose(vZusammenfassung)
'.Hyperlinks.Add .Range("G10") ,
End With
End Sub
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
|