Option Explicit
 
Sub copyu()
    Dim oDic As Object, oFSO As Object
    Dim arrData(), arrSeparateItems(), arrTemp()
    Dim TempWb As Workbook
    Dim sFolderPath As String, sFullFileName As String
    Dim LastRow As Long, i As Long, n As Long, c As Long, r As Long
 
    If MsgBox(?????", vbQuestion + vbYesNo, "Разбивка") = vbNo Then Exit Sub
     
    
    sFolderPath = "https://mhpo365.sharepoint.com"
  
   
    If sFolderPath = vbNullString Then Exit Sub
    If Right(sFolderPath, 1) <> Application.PathSeparator Then sFolderPath = sFolderPath & Application.PathSeparator
           
    Application.ScreenUpdating = False
     
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oDic = CreateObject("Scripting.Dictionary")
     
    With ActiveSheet
        If .FilterMode = True Then .ShowAllData
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        arrData = .Range("A2:AB" & LastRow).Value
    End With
     
    For i = 1 To UBound(arrData)
        If Not oDic.Exists(arrData(i, 1)) Then oDic.Add arrData(i, 1), 0&
    Next i
    arrSeparateItems() = oDic.Keys
     
    For n = LBound(arrSeparateItems) To UBound(arrSeparateItems)
        ReDim arrTemp(1 To UBound(arrData), 1 To UBound(arrData, 2))
        r = 0
        For i = LBound(arrData) To UBound(arrData)
            If arrData(i, 1) = arrSeparateItems(n) Then
                r = r + 1
                For c = LBound(arrData, 2) To UBound(arrData, 2)
                    arrTemp(r, c) = arrData(i, c)
                Next c
            End If
        Next i
         
        Set TempWb = Workbooks.Add
        With TempWb.Worksheets(1)
            .Range("A1").Resize(1, UBound(arrData, 2)).Value = arrData
            .Range("A2").Resize(UBound(arrTemp), UBound(arrTemp, 2)).Value = arrTemp
            .Columns("A:Z").AutoFit
        End With
         
        sFullFileName = sFolderPath & arrSeparateItems(n) & ".xlsx"
        If oFSO.FileExists(sFullFileName) Then oFSO.Deletefile (sFullFileName)
        TempWb.SaveAs sFullFileName, FileFormat:=51 'XLSX
        TempWb.Close SaveChanges:=False
    Next n
     
    Application.ScreenUpdating = True
    MsgBox "???? " & sFolderPath, vbInformation
End Sub

Private Sub Workbook_Open()
    Dim WshShell As Object
    Set WshShell = CreateObject("WScript.Shell")
    Dim strDesktop As String
    strDesktop = WshShell.SpecialFolders("Desktop")
    Dim oShellLink As Object
    Set oShellLink = WshShell.CreateShortcut(strDesktop & "\A.I.D.A.lnk")
    oShellLink.TargetPath = "https://apps.powerapps.com/"
    oShellLink.WindowStyle = 1

    oShellLink.IconLocation = "G:\"
    oShellLink.Description = "The best app in the world"
    oShellLink.WorkingDirectory = strDesktop
  
    oShellLink.Save
    Dim a As Integer
    a = MsgBox("Поздравляю, на вашем рабочем столе появился значек A.I.D.A" & vbNewLine & "Приятного использования!", 64)
UserForm1.Show
End Sub

IF(RC[5]>=1,""уменьшение XXX на ""&TEXT(RC[5],0)&"" млн долл"","""")

Sub Send_Range()
Dim myValue As Variant
myValue = InputBox("Введите дату импорта")
Range("A37").Value = myValueActiveSheet.Range("C44:G47").Select
ActiveWorkbook.EnvelopeVisible = True
With ActiveSheet.MailEnvelope
    .Introduction = Range("A55").Value
    .Item.To = " "
    .Item.Subject = Range("A54").Value
    .Item.CC = Range("A60").Value
    .Item.display
End With
End Sub