填充表格后，创建了特定表的超链接（Excel VBA）

Question

我解释了我的问题：

我有一种表格，其中我注册了供应商的名称和交货票据编号。然后将此数据保存在该供应商特定的供应商节中（每个供应商都有自己的评估表），该表单的副本在重置为0之前以PDF格式打印。

我想创建一个执行以下操作的超链接：通过单击超链接（超链接=与供应商交付相对应的交付说明号），打开相应的PDF文件。

我目前有一个可行的代码，但没有超链接。我想用ActiveCell.Value =超链接替换ActiveCell.value = Lieferschein_nr到我的PDF。这是我的代码（抱歉，其中一些德语单词）：

Dim Datum As String, Lieferschein_Nr As String, No As Integer, Wareneingang_bewertung As String, Ist_Menge As String, Qualitätsprüfung_bewertung As String, bestellnummer As Double, Sage_Nr As String, Liefermenge As Double, Lieferant As String
Dim Chemin, lien, lien2 As String, c As Range
Worksheets("Wareneingangsbewertung").Select ' select the worksheet Wareneingangsbewertung and extract the important values
'Following values are important for the analysis
Datum = Range("D1")
Lieferschein_Nr = Range("B5")
Wareneingang_bewertung = Range("D8")
Mengeprüfung_bewertung = Range("D15")
Qualitätsprüfung_bewertung = Range("D19")
bestellnummer = Range("B4")
Sage_Nr = Range("B6")
Liefermenge = Range("D5")
Lieferant = Range("B1")
Ist_Menge = Range("D6")

'Preview if needed
'Sheets(Array("Wareneingangsbewertung")).PrintPreview

Worksheets("Wareneingangsbewertung").Activate

box1 = MsgBox("Wollen Sie  Daten übertragen und drucken?", vbYesNo) ' Confirmation Message asking if the Process should start and save the value in the differents sheets
If box1 = vbNo Then 'If no we exit the Programm and stay on the Wareneingangsbewertung Page to make changes
Exit Sub
End If


      Dim cell As Range, cell2 As Boolean
    For Each cell In Range("B1,B4,B5,B6,D2,D5,D6,B9,B10,B11,B12,B13,B16,B20") ' define this cells as important cells. Those Cells have to be fullfilled or the programm wont save the values in the other sheets
        If cell.value = "" Then
            'Selektion auf die Zelle setzen
            cell.Select
            MsgBox "Das Pflichtfeld in Zelle " & cell.Address & " wurde nicht ausgefüllt!", vbExclamation ' When the Field isn't complited an Message will pop up and aks the user to fill the missing cells
        cell2 = True
        End If
        Next ' Go to the next cell without value
        If cell2 = True Then
       Exit Sub ' exit the programme once all the requested fields that need to be filled were shown. The user cann fill them again
        End If
        If cell2 = False Then ' Once all the requested field were correctly fild the programm can start. All the value are being copied in the differents sheets
        
' When all the requested fields are filled and the user selects YES the Process can start
If box1 = vbYes Then
MsgBox "Daten werden übertragen." & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "Formular wird gedruckt." ' Message showing the beginning of the programm
Dim xRg As Excel.Range ' define the object xRg as range
Dim wSh As Excel.Worksheet ' define the object wBk as worksheet
Dim wBk As Excel.Workbook ' define the object wBk as workbook

Set wSh = Worksheets("Choices") ' Set the active worksheet as Choices
Set wBk = ActiveWorkbook ' In this worksbook
Application.ScreenUpdating = False
For Each xRg In wSh.Range("E3:E72") ' Do the process for all the suppliers presents in the  List in the Sheet Choices
With wBk

If Worksheets("Wareneingangsbewertung").Range("B1") = xRg.value Then ' If the Worksheet ist the same as the Supplier name then the process can start
Worksheets(xRg.value).Select ' xRG.Value is the name of the sheet/ supplier sheet
Worksheets(xRg.value).Range("B11").Select ' select B11 , the first cell for the supplier evaluation
If Worksheets(xRg.value).Range("B11").Offset(1, 0) <> "" Then ' Fill the first cells that is free. If B11 or the following are filled then we go to the next free cell
Worksheets(xRg.value).Range("B11").End(xlDown).Select ' go down
End If

ActiveCell.Offset(1, 0).Select 'move from the active cell once to one under
ActiveCell.value = Datum 'put the date

ActiveCell.Offset(0, 1).Select 'move from the active cell once to the right
ActiveCell.value = Lieferschein_Nr  
"...."
End If

On Error GoTo 0
End With
Next xRg 'Go to the next Range
Application.ScreenUpdating = False
' print in pdf 
Worksheets("Wareneingangsbewertung").Activate
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="D:\Tool Supplier Evaluation\" & Range("B5").value & ".pdf" ' => Part that work well


' Code i tried but that doesn't work

hypertexteChemin = "D:\Tool Supplier Evaluation\"
lien = Chemin & Worksheets("Wareneingangsbewertung").Range("B5").value
ActiveCell.value = ActiveSheet.Hyperlinks.Add(ActiveCell, Address:="", SubAddress:=lien, TextToDisplay:=Worksheets("Wareneingangsbewertung").Range("B5").value)