Cells.Replace What:="Информация за указанный период", Replacement:= _
        "=""Расход топлива за "" &  ТЕКСТ(ДАТАМЕС(0;$L$7);""ММММ"") & ""   "" & $L$9 & "" г.""" _
        , LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False, _
        SearchFormat:=False, ReplaceFormat:=False

Sub qwe()
ПроцентУвеличенияЦены = 8

Range(Cells(24, 9) & ":" & Cells(60, 9)) = _
Range(Cells(24, 9) & ":" & Cells(60, 9)s) / 100 * (100 + ПроцентУвеличенияЦены)
    
End Sub

Sub ВидыТопливаЛитрыСредняяЦена()
  
 Sheets("ГПН").Select
  
'===============Создаем словарь===========
Dim dic
Set dic = CreateObject("Scripting.Dictionary") 'создаем словарь

   dic.CompareMode = TextCompare ' текстовый режим - игнорирует регистр
    
For i = 2 To Cells(Rows.Count, 3).End(xlUp).row 'цикл с ДВАДЦАТОЙ строки листа до последней заполненной
    k = Range("D" & i) 'создаем ключ для словаря сцепкой ячеек. Все ключи в словаре уникальны
    it = Range("E" & i) 'значение по ключу, в примере - количество
                If dic.Exists(k) Then 'проверяем, есть ли уже такой ключ в словаре
                  dic.item(k) = dic.item(k) + it 'если есть, суммируем колличество с тем, что уже было ранее
                Else
                  dic.Add k, it 'если нет, делаем в словаре новую запись
                End If
Next

Rows("1:" & dic.Count + 7).Insert 'вставляем сверху строки

СтрокаВыгрузки = 1 'строка формирования заголовка и первая строка для выгрузки данных
[a1] = "Вид топлива": [b1] = "Кол-во л.": 'в пятой строке делаем шапку

i = СтрокаВыгрузки + 1 'с этой строки будем выгружать данные из словаря
For Each ky In dic.keys 'цикл переборки всех записанных ключей
    ar = ky 'разделяем сцепку обратно, получаем два элемента
    Range("A" & i) = ar 'записываем эти элементы в ячейки
    Range("B" & i) = dic.item(ky) 'записываем в ячейку количество
     
    i = i + 1 'переходим к следующей строке
     
    k = 1
    k = k + 1
    Range("A" & i & ",A" & i - 1).MergeCells = True
 
Next
 
dic.RemoveAll
End Sub

Feedback Type:
Frown (Error)

Error Message:
Исключение из HRESULT: 0x800A03EC

Stack Trace:
   в Microsoft.Mashup.Client.Excel.NativeExcelFunctionsBase.ValidateResult(Int32 result, Int32[] expectedValues)
   в Microsoft.Mashup.Client.Excel.Shim.NativeFillServices.PerformPostRefreshFixups(IWorkbook workbook, IListObject listObject, String[] columnNames, FillColumnType[] columnTypes, String[] previousColumnNames, FillColumnType[] previousColumnTypes, FillColumnType[] recordFieldTypes, Boolean removeBlankColumns, Boolean applyResultStyle)
   в Microsoft.Mashup.Client.Excel.Fill.PollingRefreshFillSession.CompleteRefresh(IWorkbook workbook, Boolean onTimer)
   в Microsoft.Mashup.Client.Excel.Fill.PollingRefreshFillSession.UpdateRefreshStatus(IWorkbook workbook, Boolean onTimer)
   в Microsoft.Mashup.Client.Excel.Fill.PollingRefreshFillSession.ResumeFill(Boolean onTimer)
   в Microsoft.Mashup.Client.Excel.PollingFillManager.<UpdateQueries>b__a(IFillSession fillSession)
   в Microsoft.Mashup.Client.UI.Shared.Model.QueriesUtilities.ForEachWithChangeScope[T](IEnumerable`1 items, Func`2 getQueries, Action`1 action)
   в Microsoft.Mashup.Client.Excel.Fill.FillManager.ForEachFillSessionByWorkbook(Action`1 action)
   в Microsoft.Mashup.Client.Excel.PollingFillManager.<OnFillUpdateTimerTick>b__6()
   в Microsoft.Mashup.Host.Document.ExceptionHandlerExtensions.HandleExceptions(IExceptionHandler exceptionHandler, Action action)

Stack Trace Message:
Исключение из HRESULT: 0x800A03EC

Invocation Stack Trace:
   в Microsoft.Mashup.Host.Document.ExceptionExtensions.GetCurrentInvocationStackTrace()
   в Microsoft.Mashup.Client.UI.Shared.FeedbackErrorInfo..ctor(String message, Exception exception, Nullable`1 stackTraceInfo)
   в Microsoft.Mashup.Client.Excel.Native.NativeUserFeedbackServices.ReportException(IWindowHandle activeWindow, IUIHost uiHost, FeedbackPackageInfo feedbackPackageInfo, Exception e, Boolean useGDICapture)
   в Microsoft.Mashup.Client.UI.Shared.UnexpectedExceptionHandler.<>c__DisplayClass1.<HandleException>b__0()
   в Microsoft.Mashup.Client.UI.Shared.UnexpectedExceptionHandler.HandleException(Exception e)
   в Microsoft.Mashup.Host.Document.ExceptionHandlerExtensions.HandleExceptions(IExceptionHandler exceptionHandler, Action action)
   в System.Windows.Forms.Timer.OnTick(EventArgs e)
   в System.Windows.Forms.Timer.TimerNativeWindow.WndProc(Message& m)
   в System.Windows.Forms.NativeWindow.Callback(IntPtr hWnd, Int32 msg, IntPtr wparam, IntPtr lparam)


Supports Premium Content:
True

each if[Дата]=""and[Тов]="**e**"then"удалить"else"")

    ActiveWorkbook.Saved = True
    ActiveWorkbook.Save
    Application.Quit

Sub УдалитьМодули()
    'On Error Resume Next
    ИтоговаяКнига = Sheets(1).Name & " e-mail.xlsm"
    
    'Активируем кингу для отправки по e-mail
    Workbooks(ИтоговаяКнига).Activate
    
    'Удаляем Module и UserForm's
                    Set VBProj = ActiveWorkbook.VBProject.VBComponents
                    VBProj.Remove VBProj("ДобавитьНовогоКонтрагента")
                    VBProj.Remove VBProj("ДобавитьОснование")
                    VBProj.Remove VBProj("УдалитьОснование")
                    VBProj.Remove VBProj("УказатьОтветственного")
                    VBProj.Remove VBProj("Календарь")
                    VBProj.Remove VBProj("Module2")

            'Удаляем код из ЭтаКнига-------
            Dim oVBComponent As Object, lCountLines As Long
            Set oVBComponent = ActiveWorkbook.VBProject.VBComponents("ЭтаКнига")
            With oVBComponent
                lCountLines = .CodeModule.CountOfLines
                .CodeModule.DeleteLines 1, lCountLines
            End With
            Set oVBComponent = Nothing
            '------------------------------
     
'MsgBox "Сформирован отчет для [-  " & Sheets(1).Name & "  -]", vbOKOnly + vbInformation, ""

        Call Сохранить
                'ОтправляемФайл
                If ОтправляемФайл = True Then
                    
                    Dim FullStr As String
                
                    Смайлик = Sheets(1).Range("A7")
                
                    FullStr = "C:\Program Files (x86)\Mozilla Thunderbird\thunderbird.exe"
                    FullStr = FullStr & " -compose to=" & Почта
                    FullStr = FullStr & " ,subject=""" & Смайлик & "Транзакционный отчет [ " & ActiveWorkbook.ActiveSheet.Name & " ]"""
                    FullStr = FullStr & " ,body="" """
                    FullStr = FullStr & " ,attachment=" & ThisWorkbook.Path & "\" & ИтоговаяКнига

                    Shell FullStr, 1

                End If
                
Windows(ИтоговаяКнига).Activate
Call Сохранить

'Закрываем Книгу
'ActiveWindow.Close
End Sub

Sub Сохранить()
ActiveWorkbook.Save
End Sub

For Check = 1 To 6
For Check2 = 8 To 13


If CheckBox(Check).Value = True Then
Range("a" & Check).Value = TextBox(Check).Value
КолвоСтрок = КолвоСтрок + 1

    If TextBox(Check2).Value = 0 Then
        ВыбранноеТопливо = ВыбранноеТопливо & TextBox(Check).Value & Chr(10)
        Else
        ВыбранноеТопливо = ВыбранноеТопливо & TextBox(Check).Value & ":   " & TextBox(Check2).Value & " " & Валюта & Chr(10)
    End If
    
End If

Next
Next

Private Sub CommandButton1_Click()
ActiveWorkbook.RemovePersonalInformation = False

'Выбираем валюту
If OptionButton1.Value = True Then Валюта = "л."
If OptionButton2.Value = True Then Валюта = "руб."


'Выбираем виды топлива.  Если стоит галочка, значит кнопка активна
КолвоСтрок = 0

For Check = 1 To 6
For Check2 = 8 To 13


If CheckBox(Check).Value = True Then
Range("a" & Check).Value = TextBox(Check).Value
КолвоСтрок = КолвоСтрок + 1

    If TextBox(Check2).Value = 0 Then
        ВыбранноеТопливо = ВыбранноеТопливо & TextBox(Check).Value & Chr(10)
        Else
        ВыбранноеТопливо = ВыбранноеТопливо & TextBox(Check).Value & ":   " & TextBox(Check2).Value & " " & Валюта & Chr(10)
    End If
    
End If

Next
Next

'If CheckBox1.Value = True Then Range("a1").Value = TextBox1.Value: КолвоСтрок = КолвоСтрок + 1: If TextBox8.Value = 0 Then ВыбранноеТопливо = ВыбранноеТопливо & TextBox1.Value & Chr(10): If TextBox8.Value > 0 Then ВыбранноеТопливо = ВыбранноеТопливо & TextBox1.Value & ":   " & TextBox8.Value & " " & Валюта & Chr(10)
'If CheckBox2.Value = True Then Range("a2").Value = TextBox2.Value: КолвоСтрок = КолвоСтрок + 1: If TextBox9.Value = 0 Then ВыбранноеТопливо = ВыбранноеТопливо & TextBox2.Value & Chr(10): If TextBox9.Value > 0 Then ВыбранноеТопливо = ВыбранноеТопливо & TextBox2.Value & ":   " & TextBox9.Value & " " & Валюта & Chr(10)
'If CheckBox3.Value = True Then Range("a3").Value = TextBox3.Value: КолвоСтрок = КолвоСтрок + 1: If TextBox10.Value = 0 Then ВыбранноеТопливо = ВыбранноеТопливо & TextBox3.Value & Chr(10): If TextBox10.Value > 0 Then ВыбранноеТопливо = ВыбранноеТопливо & TextBox3.Value & ":   " & TextBox10.Value & " " & Валюта & Chr(10)
'If CheckBox4.Value = True Then Range("a4").Value = TextBox4.Value: КолвоСтрок = КолвоСтрок + 1: If TextBox11.Value = 0 Then ВыбранноеТопливо = ВыбранноеТопливо & TextBox4.Value & Chr(10): If TextBox11.Value > 0 Then ВыбранноеТопливо = ВыбранноеТопливо & TextBox4.Value & ":   " & TextBox11.Value & " " & Валюта & Chr(10)
'If CheckBox5.Value = True Then Range("a5").Value = TextBox5.Value: КолвоСтрок = КолвоСтрок + 1: If TextBox12.Value = 0 Then ВыбранноеТопливо = ВыбранноеТопливо & TextBox5.Value & Chr(10): If TextBox12.Value > 0 Then ВыбранноеТопливо = ВыбранноеТопливо & TextBox5.Value & ":   " & TextBox12.Value & " " & Валюта & Chr(10)
'If CheckBox6.Value = True Then Range("a6").Value = TextBox6.Value: КолвоСтрок = КолвоСтрок + 1: If TextBox13.Value = 0 Then ВыбранноеТопливо = ВыбранноеТопливо & TextBox6.Value & Chr(10): If TextBox13.Value > 0 Then ВыбранноеТопливо = ВыбранноеТопливо & TextBox6.Value & ":   " & TextBox13.Value & " " & Валюта & Chr(10)

'Выводим ошибки о невыбранных параметрах
If КолвоСтрок = 0 Then MsgBox "" & vbNewLine & "" & vbNewLine & "Выберете вид топлива!" & vbNewLine & "" & vbNewLine & "", vbOKOnly + vbExclamation, "": Exit Sub
If Валюта = "" Then MsgBox "" & vbNewLine & "" & vbNewLine & "Выберете Литры или Рубли!" & vbNewLine & "" & vbNewLine & "", vbOKOnly + vbExclamation, "": Exit Sub


msg = MsgBox("Проверьте правильность указанных параметров." & vbNewLine & vbNewLine & vbNewLine & vbNewLine & _
"Виды топлива (" & КолвоСтрок & "):" & vbNewLine & vbNewLine & ВыбранноеТопливо & vbNewLine & vbNewLine & vbNewLine & _
"Валюта: " & vbNewLine & vbNewLine & Валюта & vbNewLine & vbNewLine & vbNewLine & vbNewLine & vbNewLine & vbNewLine & _
"Все верно?", vbYesNo + vbInformation, "Проверьте правильность указанных данных")
If msg = vbNo Then Exit Sub


Unload Me
End Sub

Sub CreateNewZip(sPath As Str[SIZE=24pt][B][/B][/SIZE]ing)
    If Dir(sPath) <> "" Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub


Sub ИзвлечьВсеИзАрхива()
    
    On Error Resume Next
    
    '===Переменные==================
    ПапкаДляАрхива = "C:\Users\" & Environ("UserName") & "\AppData\Local\Microsoft\Office\16.0\PowerQuery\User"
    ПутьДоАрхива = ПапкаДляАрхива & ".zip"
    '===============================
    
    
    
    MkDir ПапкаДляАрхива ' создаем папку с именем архива
    
    
    
    '===Извлекаем файлы из архива===
    With CreateObject("Shell.Application")
    .Namespace((ПапкаДляАрхива)).CopyHere .Namespace((ПутьДоАрхива)).Items
    End With
    '===============================
    
    
    
    
    
    '===Меняем содержимое SETTINGS.XLM===
    Workbooks.OpenXML Filename:= _
        ПапкаДляАрхива & "\UserInterface\Settings.xml" _
        , LoadOption:=xlXmlLoadImportToList

    Kill ПапкаДляАрхива & "\UserInterface\Settings.xml"

    Cells.Find(What:="GlobalPrivacyLevel", After:=ActiveCell, LookIn:= _
        xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Range("B" & Selection.Row).Value = "l0"

    ActiveWorkbook.SaveAsXMLData Filename:= _
        ПапкаДляАрхива & "\UserInterface\Settings.xml" _
        , Map:=ActiveWorkbook.XmlMaps("UISettingsConfig_карта")
        
      ActiveWorkbook.Close False
    '===============================
    
    
    
    
    
    Kill ПутьДоАрхива    ' удаляем старый архив

    CreateNewZip (ПутьДоАрхива) 'создаем пустой ZIP-архив
    
    
    '===Помещаем папку обратно в архив=====================================
    With CreateObject("Shell.Application").Namespace(("C:\Users\" & Environ("UserName") & "\AppData\Local\Microsoft\Office\16.0\PowerQuery\User.zip"))
    .CopyHere CreateObject("Shell.Application").Namespace(ПапкаДляАрхива).Items
    End With
    '======================================================================

    
    '===Дожидаемся окончания архивации=====================================
    Do Until CreateObject("Shell.Application").Namespace((ПутьДоАрхива)).Items.Count = CreateObject("Shell.Application").Namespace((ПапкаДляАрхива)).Items.Count
        DoEvents
    Loop
    '======================================================================

    Shell "cmd /c rd /S/Q """ & ПапкаДляАрхива & """"     'ЗАМЕТАЕМ СЛЕДЫ ( удаляем временную папку )
End Sub

cell = "https://admin.com/?page_size=9999"
Shell ("C:\Program Files (x86)\Google\Chrome\Application\chrome.exe" & " " & cell)

Private Sub Worksheet_Change(ByVal Target As Range)
                                       On Error Resume Next                             ' ОТКЛЮЧИТЬ ПОКАЗ ОШИБОК
                                       Application.DisplayAlerts = False                ' ОТКЛЮЧИТЬ ВЫВОД СИСТЕМНЫХ СООБЩЕНИЙ
                                       Application.ScreenUpdating = False               ' ОТКЛЮЧИТЬ ОБНОВЛЕНИЕ ЭКРАНА
                                       ActiveWorkbook.RemovePersonalInformation = False ' ОТКЛЮЧЕНИЕ ОКНА С ТЕКСТОМ О ПЕРСОНАЛЬНЫХ ДАННЫХ
'=========================================================================
    If ActiveSheet.Name <> "Операции с картами" Then Exit Sub
    Dim rng As Range: Set rng = [O23:O24] 'диапазон Вашей таблицы
    If Not Intersect(rng, Target) Is Nothing Then

    ApLe = Application.Left
    ApTo = Application.Top
    ApWi = Application.Width
    ApHe = Application.Height
    
    Call OK_ВыбратьНОМЕРАГруппКарт
    
    Application.Left = ApLe
    Application.Top = ApTo
    Application.Width = ApWi
    Application.Height = ApHe
    
    End If    
End Sub

=if [Столбец1] = "*92*" then "Бензин АИ-92" else "Другое" 

sub 123()
msgbox object(selection).Name

msgbox object(selection).TextFrame
end SUB