Sub pismaWychodząceDodajHiperlacza()
    'Utworzenie pustej listy, w której będą przechowywane pliki
    Dim files()

    'Ścieżka do plików
    Path = "D:\KORESPONDENCJA_ODC.7\Pisma wychodzące"

    'Wypełnienie listy plikami znajdującymi się w ścieżce
    files = listfiles(Path)

    Dim zakresHiperlaczy As Range
    Dim cell As Range

    'Wybór komórek w którch są hiperłącza (kolumna A od 3 do końca)
    Set zakresHiperlaczy = Range("A3:A" & Cells(Rows.Count, 1).End(xlUp).Row)

    'Pytanie czy ingerować w istniejące hiperłącza
    answer = MsgBox("Naprawić istniejące hiperłącza?", vbQuestion + vbYesNo + vbDefaultButton2, "Dodanie hiperłączy")

    'Pętla wybierająca każdą komórkę z ustawionego wcześniej zakresu
    For Each cell In zakresHiperlaczy
        'Jeżeli użytkownik chce ingerować w istniejące hiperłącza (naprawić je) lub nie ma hiperłącza w tej komórce to:
        If answer = vbYes Or cell.Hyperlinks.Count <= 0 Then

            'Jeżeli ta komórka ma wpisaną jakąś wartość:
            If cell.Text <> "" Then

                'W komórce wpisany jest numer pliku
                Name = cell.Text
                'Uzupełniamy numer zerami z przodu jeżeli ma mniej niż 4 cyfry
                Do While Len(Name) < 4
                    Name = "0" + Name
                Loop

                'Wyszukujemy pliku o takiej nazwie w liście plików
                filename = (findFile(Name, files))

                'Jeżeli taka nazwa została znaleziona to:
                If filename <> "" Then

                    'Tworzymy nową ścieżkę z ścieżki do plików i nazwy pliku - jest to ścieżka do konkretnego pliku
                    newPath = Path + "\" + filename

                    'Usuwamy stare hiperłącze (jeżeli nie ma to nic się nie stanie)
                    cell.Hyperlinks.Delete

                    'Dodajemy nowe hiperłacze
                    cell.Hyperlinks.Add Anchor:=cell, Address:=newPath
                End If
            End If
        End If
    Next cell

End Sub

'Funkcje poniżej wziąłem z internetu i nie przyglądałem się im jak dokładnie działają
Function findFile(ByVal filenum As String, filesArray() As Variant)
    For i = 0 To (UBound(filesArray) - LBound(filesArray))
        filename = filesArray(i)
        If startsWith(filename, filenum) = True Then
            findFile = filename
            Exit Function
        End If
    Next i
End Function


Public Function startsWith(ByVal str As String, prefix As String) As Boolean
    startsWith = Left(str, Len(prefix)) = prefix
End Function

Function listfiles(ByVal sPath As String)

    Dim vaArray()
    Dim i           As Integer
    Dim oFile       As Object
    Dim oFSO        As Object
    Dim oFolder     As Object
    Dim oFiles      As Object

    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(sPath)
    Set oFiles = oFolder.files

    If oFiles.Count = 0 Then Exit Function

    ReDim vaArray(0 To oFiles.Count - 1)
    i = 0
    For Each oFile In oFiles
        vaArray(i) = oFile.Name
        i = i + 1
    Next

    listfiles = vaArray

End Function