Thema Datum  Von Nutzer Rating
Antwort
Rot Hyperlink übernehmen
21.08.2020 10:01:44 Jan Sutter
NotSolved
21.08.2020 13:03:59 Gast9741
NotSolved
21.08.2020 13:06:07 Gast9741
NotSolved
21.08.2020 13:21:17 Gast97678
NotSolved

Ansicht des Beitrags:
Von:
Jan Sutter
Datum:
21.08.2020 10:01:44
Views:
1131
Rating: Antwort:
  Ja
Thema:
Hyperlink übernehmen

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

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:

 
 

  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot Hyperlink übernehmen
21.08.2020 10:01:44 Jan Sutter
NotSolved
21.08.2020 13:03:59 Gast9741
NotSolved
21.08.2020 13:06:07 Gast9741
NotSolved
21.08.2020 13:21:17 Gast97678
NotSolved