Dim Cell As Range
    Dim Cell2 As Range
    
    For Each Cell In Range("B6:B60000")
        If Cell <> "" Then ActiveSheet.Hyperlinks.Add Range("b" & Rows.Count).End(xlUp), ПутьКФайлу
    Next

    For Each Cell2 In Range("B60001:B160000")
        If Cell2 <> "" Then ActiveSheet.Hyperlinks.Add Range("b" & Rows.Count).End(xlUp), ПутьКФайлу
    Next

Function КОД_ПАРТИИ(Код_номенклатуры, Дата_производства)
Dim m As String
Dim y As String
Dim d As String

If Код_номенклатуры = 0 Then
    КОД_ПАРТИИ = "Введите код номенклатуры!"
Exit Function
ElseIf Дата_производства = 0 Then
    КОД_ПАРТИИ = "Введите дату!"
Exit Function
End If

If Month(Дата_производства) = 1 Then
    m = "R"
End If

If Year(Дата_производства) = 2019 Then
    y = "X"
End If

If Day(Дата_производства) = 1 Then
    d = "R"
End If

КОД_ПАРТИИ = m & y & d

End Function

Function TEST1(A, B)
Dim iFullName As String

iFullName = "C:\Program Files\1234.jpg"
If Dir(iFullName) = "" Then
    TEST1 = "ffgg"
    Exit Function
Else
    TEST1 = A & B
End If
End Function

Sub Backup_Active_Workbook()
    Dim x As String
    strPath = "E:\TEMP" 
    On Error Resume Next
    x = GetAttr(strPath) And 0
    If Err = 0 Then 
        strDate = Format(Now, "dd-mm-yy hh-mm")
        FileNameXls = strPath & "\" & Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 1) & " (" & strDate & ")" & ".xls"
        ActiveWorkbook.SaveCopyAs Filename:=FileNameXls
    End If
End Sub

Private Sub backup()
    Call Backup_Active_Workbook
    Application.OnTime Now + TimeValue("00:30:00"), "backup"
End Sub

Sub RunOnTime()
    Application.OnTime Now + TimeValue("00:30:00"), "module8.backup"
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
       If Not Intersect(Target, Range("D2:D10000")) Is Nothing Then
            Call t
        End If
 End Sub

Private Sub CommandButton6_Click()
    If Selection.Cells.Count > 1 Then Exit Sub
    With Application.FileDialog(msoFileDialogFilePicker)
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        ImaFile = .SelectedItems(1)
    End With
    Me.Label19 = ImaFile
End Sub

Private Sub CommandButton1_Click()
With Cells(iLastRow + 1, 4)
    .Value = Me.TextBox3
            .ClearComments
            If ImaFile <> Empty Then
                .AddComment.Shape.Fill.UserPicture (ImaFile)
                With .Comment.Shape
                    .Width = 300
                    .Height = 200
                End With
            End If
    End With

Sub t()
    anncalendar.Show
    If anncalendar.Value = 0 Then
     ActiveCell = 23
        Else
     ActiveCell = anncalendar.Value
    End If
End Sub