Sub MyMacro(ByVal i As Long)
  Debug.Print "MyMacro", i
End Sub

Item.OnAction = "'MyMacro(" & i & ")'"

Sub test()
  Dim fDialog As FileDialog, folder As Object, fso As Object, fName As String
  Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
  With fDialog
    If .Show = 0 Then Exit Sub
    fName = .SelectedItems(1)
  End With
  
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set folder = fso.getFolder(fName)
  folder.Name = "Folder_New"
  
  Set folder = Nothing
  Set fso = Nothing
End Sub

txt = "y"   ' текст для поиска в ячейке A1

Option Explicit
Dim cmdBar1 As CommandBar, cmdBar2 As CommandBar
Sub MakeMenu()
  Dim cmdBar As CommandBar
  For Each cmdBar In Application.CommandBars
     If cmdBar.Name = "Cell" Then
       If cmdBar1 Is Nothing Then
         Set cmdBar1 = cmdBar
         MakeMenu_2 cmdBar
       Else
         Set cmdBar2 = cmdBar
         MakeMenu_2 cmdBar
         Exit For
       End If
     End If
  Next cmdBar
End Sub

Sub MakeMenu_2(ByVal cmdBar)
'   Добавление пунктов контекстного меню
    Dim Cap(1 To 15)
    Dim Mac(1 To 15)
    Dim NewMenu As CommandBarControl
    Dim Item As CommandBarControl
    Dim MenuCount As Integer
    Dim i As Integer
    
    Cap(1) = "Выделить вверх (клавиши <Ctrl+Shift+Down>)"
    Mac(1) = "SelectDown"
    Cap(2) = "Выделить вверх (клавиши <Ctrl+Shift+Up>)"
    Mac(2) = "SelectUp"
    Cap(3) = "Выделить вправо (клавиши <Ctrl+Shift+Right>)"
    Mac(3) = " SelectToRight"
    Cap(4) = "Выделить влево (клавиши <Ctrl+Shift+Left>)"
    Mac(4) = " SelectToLeft"
    Cap(5) = "Выделить текущий регион (клавиши <Ctrl+Shift+*>)"
    Mac(5) = " SelectCurrentRegion"
    Cap(6) = "Выделить активную область (клавиши End, Home, <Ctrl+Shift+Home>)"
    Mac(6) = " SelectActiveArea"
    Cap(7) = "Выделить ячейки, смежные со столбцом с активной ячейкой"
    Mac(7) = " SelectActiveColumn"
    Cap(8) = "Выделить ячейки, смежные со строкой с активной ячейкой"
    Mac(8) = " SelectActiveRow"
    Cap(9) = "Выделить весь столбец (клавиши <Ctrl+пробел>)"
    Mac(9) = " SelectEntireColumn"
    Cap(10) = "Выделить всю строку  (клавиши <Shift+пробел>)"
    Mac(10) = " SelectEntireRow"
    Cap(11) = "Выделить весь лист (клавиши <Ctrl+A>)"
    Mac(11) = " SelectEntireSheet"
    Cap(12) = "Активизировать следующую пустую ячейку снизу"
    Mac(12) = " ActivateNextBlankDown"
    Cap(13) = "Активизировать следуущую пустую ячейку справа"
    Mac(13) = " ActivateNextBlankToRight"
    Cap(14) = "Выделить диапазон строки от первой непустой ячейки до последней непустой ячейки"
    Mac(14) = " SelectFirstToLastInRow"
    Cap(15) = "Выделить диапазон столбца от первой непустой ячейки до последней непустой ячейки"
    Mac(15) = " SelectFirstToLastInColumn"


'   Удалить меню, если оно уже существует
    On Error Resume Next
    cmdBar.Controls("&Демонстрация выделения").Delete
    On Error GoTo 0
    
'   Добавление меню
    MenuCount = cmdBar.Controls.Count
    Set NewMenu = cmdBar.Controls.Add(Type:=msoControlPopup, temporary:=True)
    NewMenu.Caption = "&Демонстрация выделения"
    
'   Добавление пунктов меню
    For i = 1 To 15
        Set Item = NewMenu.Controls.Add(Type:=msocontrolbutton, temporary:=True)
        With Item
            .Caption = Cap(i)
            .OnAction = Mac(i)
            If i Mod 4 = 0 Then .BeginGroup = True
        End With
    Next i
End Sub

Sub DeleteMenu()
'   Удаление меню перед закрытием
    On Error Resume Next
    cmdBar1.Controls("&Демонстрация выделения").Delete
    cmdBar2.Controls("&Демонстрация выделения").Delete
End Sub

Sub TestRangeFind()
    Dim rg As Range, txt As String, y As Long
    y = 2021
    Workbooks.Add
    With Range("A1")
      .NumberFormat = "D MMMM YYYY"
      .Value = DateSerial(y, 1, 1)
      Set rg = .Find(y, LookIn:=xlValues, LookAt:=xlPart)
      Debug.Print "Текст " & y & IIf(rg Is Nothing, " не", "") & " найден в ячейке со значением " & .Value
    End With
End Sub

Sub TestRangeFind2()
    Dim rg As Range, m As Long, y As Long, txt As String
    y = 2021
    txt = y   ' текст для поиска в ячейке A1
    Workbooks.Add
    With Range("A1")
        .NumberFormat = "D MMMM YYYY"
        For m = 1 To 12
            .Value = DateSerial(y, m, 1)
            .EntireColumn.AutoFit
            Set rg = .Find(txt, LookIn:=xlValues, LookAt:=xlPart)
            Debug.Print "Текст " & txt & IIf(rg Is Nothing, " не", "") & " найден в ячейке со значением " & .Value
        Next m
    End With
End Sub

Set fcell2 = Sheets("Production").Rows("1:1").Find(Format(CStr(Sheets("Vol Pack").Cells(lLastRow + i, 1).Value), "D.M"), LookIn:=xlValues, LookAt:=xlWhole)

Option Explicit

Function DelFromArh(ByVal arh As String, ByVal file As String)
    Dim fso As Object, oFolder As Object, tempPath As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    tempPath = Environ("Temp") & "\" & fso.GetTempName
    fso.CreateFolder tempPath
  
    With CreateObject("Shell.Application")
        Set oFolder = .Namespace(tempPath & "\")
        oFolder.MoveHere .Namespace(arh & "\").ParseName(file)
        oFolder.Items.Filter 64, "*.*"
        Set oFolder = Nothing
    End With

    fso.DeleteFolder tempPath
    Set fso = Nothing
End Function

Sub Test2()
    DelFromArh "C:\Temp\Temp.zip", "1.xls"
End Sub