=CALCULATE(
    SUM('Выгрузка'[Выручка]);
    USERELATIONSHIP('Выгрузка'[Дата_нач]; 'Календарь'[Дата]);
    FILTER(
        'Выгрузка';
        'Выгрузка'[Дата_нач] >= MIN('Выгрузка'[Дата_нач]) &&
        'Выгрузка'[Дата_нач] <= MAX('Выгрузка'[Дата_кон])
    )
)

1) добавляем таблицу в модель денных
2) делаем сводную
3 ) создаем меру в которую записываем следующую  формулу на dax :
=CONCATENATEX(Values(Table[Column]), Table[Column], ", ")
где table - название  сводной, column название столбца  откуда нужно вывести текст в область значений
4) добавляем меру в область значений.

=ЕСЛИ(ЕОШИБКА(ПРАВСИМВ(Ф.ТЕКСТ(ДВССЫЛ("Лист1!E"&ПОИСКПОЗ(B2;Лист1!$B$2:$B$11;0)+1)) & "";ДЛСТР(Ф.ТЕКСТ(ДВССЫЛ("Лист1!E"&ПОИСКПОЗ(B2;Лист1!$B$2:$B$11;0)+1)) & "")-НАЙТИ("/";Ф.ТЕКСТ(ДВССЫЛ("Лист1!E"&ПОИСКПОЗ(B2;Лист1!$B$2:$B$11;0)+1)) & "")+1));"'="&ЯЧЕЙКА("адрес";D2);"'="&ЯЧЕЙКА("адрес";D2)&ПРАВСИМВ(Ф.ТЕКСТ(ДВССЫЛ("Лист1!E"&ПОИСКПОЗ(B2;Лист1!$B$2:$B$11;0)+1)) & "";ДЛСТР(Ф.ТЕКСТ(ДВССЫЛ("Лист1!E"&ПОИСКПОЗ(B2;Лист1!$B$2:$B$11;0)+1)) & "")-НАЙТИ("/";Ф.ТЕКСТ(ДВССЫЛ("Лист1!E"&ПОИСКПОЗ(B2;Лист1!$B$2:$B$11;0)+1)) & "")+1))

=CALCULATE(
    SUM('Таблица1'[Сумма]);
    FILTER(
        ALL('Таблица1');  // Игнорируем все фильтры на таблице
        'Таблица1'[Элемент3] = "Расход" &&
        'Таблица1'[Элемент1] IN VALUES('Таблица1'[Элемент2])  // Учитываем текущее значение Элемента 1
    )
)

Function CustomFunction(S18 As String, T18 As Range, U17 As String, Optional Reset As Boolean = False) As Variant
    Static LastValue As Double ' Храним последнее значение
    Dim TRange As Range
    Dim SRange As Range
    Dim U17Converted As Double
    Dim Result As Double
    
    ' Обнуляем LastValue, если Reset = True
    If Reset Then
        LastValue = 0
    End If

    ' Определяем динамические диапазоны на основе строки T18
    Set TRange = Range("$T$18:T" & T18.Row)
    Set SRange = Range("$S$18:S" & T18.Row)
    
    ' Пытаемся преобразовать U17 с использованием указанной формулы
    On Error Resume Next
    U17Converted = CDbl(Left(U17, Len(U17) - InStrRev(U17, ".")) & "." & (Right(U17, Len(U17) - InStrRev(U17, ".")) / 100))
    If Err.Number <> 0 Then
        U17Converted = CDbl(U17) ' Если ошибка, просто преобразуем U17 напрямую
        Err.Clear
    End If
    On Error GoTo 0 ' Сбрасываем обработку ошибок

    If S18 = "заголовок" Then
        Result = Application.WorksheetFunction.CountIfs(TRange, T18, SRange, "заголовок")
    Else
        Result = U17Converted + 0.01
    End If
    
    ' Проверяем, является ли Result целым числом или десятичным
    If IsNumeric(Result) Then
        If Result = Int(Result) Then
            CustomFunction = Result ' Если целое, возвращаем как есть
            LastValue = Result ' Обновляем последнее значение
        Else
            ' Если десятичное, применяем указанную формулу
            Dim ResultString As String
            ResultString = CStr(Result)
            Dim DecimalPosition As Integer
            DecimalPosition = InStr(ResultString, ",")

            ' Заменяем запятую на точку для десятичного разделителя
            If DecimalPosition > 0 Then
                ResultString = Replace(ResultString, ",", ".")
            End If
            
            CustomFunction = ResultString
        End If
    Else
        CustomFunction = CVErr(xlErrValue) ' Возвращаем ошибку, если Result не числовой
    End If
    
    ' Увеличиваем значение для следующей строки
    If S18 <> "заголовок" Then
        LastValue = LastValue + 0.1
        CustomFunction = Round(LastValue, 1) ' Округляем до одного знака после запятой
        ' Заменяем запятую на точку
        CustomFunction = Replace(CStr(CustomFunction), ",", ".")
    End If
End Function

=ЕСЛИ(S18="заголовок";ЕСЛИ(S18="заголовок";СЧЁТЕСЛИМН($T$18:T18;T18;$S$18:S18;"заголовок");0);U17+0,01)

=ЕСЛИ(S18="заголовок";U18;ЛЕВСИМВ(U18;ДЛСТР(U18)-НАЙТИ(",";ТЕКСТ(U18;"0,00"))-1)&"."&--(ПРАВСИМВ(U18;ДЛСТР(U18)-НАЙТИ(",";ТЕКСТ(U18;"0,00")))))

=ДАТАЗНАЧ(ТЕКСТ([@[Дата создания]];"ДД.ММ.ГГГГ"))

= 
CALCULATE(
    SUM(Table1[Value]);
    FILTER(
        ALL(Table1);
        Table1[Account] = EARLIER(Table1[Account]) &&
        Table1[Month] <= EARLIER(Table1[Month])
    )
)

=IF(
    MAX('Table1'[Account]) = "y300";
    SUM('Table1'[Value]);
    SUM('Table1'[НарастИтог])
)

=IF(
    MAX('Table1'[Account]) = "y300";
    SUM('Table1'[Value]);
    CALCULATE(
        SUM('Table1'[Value]);
        ALL('Months')  // Игнорируем фильтры по Months
    )
)

Sub FindAndReplaceInDataValidation()
    Dim ws As Worksheet
    Dim cell As Range
    Dim findText As String
    Dim replaceText As String

    findText = InputBox("Введите текст для поиска в проверке данных:")
    replaceText = InputBox("Введите текст для замены в проверке данных:")

    For Each ws In ThisWorkbook.Worksheets
        ' Обработка проверки данных
        For Each cell In ws.UsedRange
            If cell.Validation.Type <> 0 Then ' Проверка, есть ли проверка данных
                On Error Resume Next ' Игнорировать ошибки
                Dim formula1 As String
                formula1 = cell.Validation.formula1
                
                ' Проверка, является ли формула строкой и содержит ли искомый текст
                If formula1 <> "" And InStr(formula1, findText) > 0 Then
                    formula1 = Replace(formula1, findText, replaceText)
                    cell.Validation.Modify Type:=cell.Validation.Type, AlertStyle:=cell.Validation.AlertStyle, Operator:=cell.Validation.Operator, formula1:=formula1, Formula2:=cell.Validation.Formula2
                End If
                On Error GoTo 0 ' Возврат к обычной обработке ошибок
            End If
        Next cell
    Next ws
End Sub

Dim SourceRow As Long
Dim TargetRow As Long
Dim IsDragging As Boolean

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If IsDragging Then
        TargetRow = Target.Row
        If TargetRow <> SourceRow Then
            Rows(SourceRow).Cut
            Rows(TargetRow).Insert Shift:=xlDown
            IsDragging = False
        End If
    End If
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Cells.Count = 1 Then
        SourceRow = Target.Row
        IsDragging = True
        Cancel = True
    End If
End Sub

Sub Макрос1()

    Dim r, lr, m, k, pat, i, f
    Dim myPic As Shape
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set sl = CreateObject("Scripting.Dictionary")
    pat = ActiveWorkbook.Path
    Search fso.GetFolder(pat)
    k = sl.keys
    With ActiveSheet
        lr = Cells(Rows.Count, 25).End(xlUp).Row
        m = .Cells(4, 24).Resize(lr - 3, 2).Value
        Dim rw&, co&
        For rw = 42 To 51 Step 3
            For co = 6 To 10 Step 1
                For r = 1 To UBound(m)
                    ' Check for exact match
                    If Cells(rw, co).Value = m(r, 1) Then
                        Dim iconExists As Boolean
                        iconExists = False
                        
                        ' Check if an icon already exists in the cell
                        For Each myPic In ActiveSheet.Shapes
                            If Not Intersect(myPic.TopLeftCell, Cells(rw, co)) Is Nothing Then
                                iconExists = True
                                Exit For
                            End If
                        Next myPic
                        
                        If Not iconExists Then
                            For i = 0 To UBound(k)
                                If InStr(1, k(i), m(r, 2), vbTextCompare) > 0 Then
                                    pat = sl(k(i))
                                    With .Cells(rw, co)
                                        Set myPic = ActiveSheet.Shapes.AddPicture( _
                                            Filename:=pat, _
                                            linktofile:=msoFalse, _
                                            savewithdocument:=msoCTrue, _
                                            Left:=.Offset(0, 0).Left + 1, _
                                            Top:=.Offset(0, -1).Top + 1, _
                                            Width:=.Offset(0, -1).Width - 2, _
                                            Height:=.Offset(0, -1).Height * 3 - 2)
                                        myPic.LockAspectRatio = msoFalse
                                    End With
                                    Exit For ' Exit after placing the first icon
                                End If
                            Next i
                        End If
                    End If
                Next r
            Next co
        Next rw
    End With
End Sub

= try if [Год]=2023 then [РТО] else if [Год]=2024 and [Месяц]<Date.Month(DateTime.Date(DateTime.LocalNow())) 
then (if [РТО предварительное]=0 then [РТО] else [РТО предварительное]) else [Расчет]{[Индекс]-1}*(1+[#"% откл ПМ ПГ"]) otherwise 0

let
    Источник = Table.NestedJoin(ЗадолженностьИсходник, {"Контрагент"}, ОтгрузкиИсходник, {"Контрагент"}, "ОтгрузкиИсходник", JoinKind.LeftOuter),
    #"Добавлен пользовательский объект" = Table.AddColumn(Источник, "ОтфлтрТблц", each let dt = [#"Период (конец месяца)"] in Table.Sort(Table.SelectRows([ОтгрузкиИсходник], each [Дата]<=dt), {"Дата",Order.Descending})),
    #"Добавлен пользовательский объект1" = Table.AddColumn(#"Добавлен пользовательский объект", "TabNarastItog", each let tab = Table.AddIndexColumn([ОтфлтрТблц],"Index",0), lst = tab[#"Отгрузка, руб."] in Table.AddColumn(tab,"NarastItog",each List.Sum(List.FirstN(lst, [Index]+1)))),
    #"Добавлен пользовательский объект2" = Table.AddColumn(#"Добавлен пользовательский объект1", "КолвоДнейЗадолж", each let zdlzh = [#"Текущая задолженность, руб."] in Duration.TotalDays([#"Период (конец месяца)"]-List.Last(Table.SelectRows([TabNarastItog], each [NarastItog]<=zdlzh)[Дата]))),
    #"Другие удаленные столбцы" = Table.SelectColumns(#"Добавлен пользовательский объект2",{"Период (конец месяца)", "Контрагент", "КолвоДнейЗадолж"})
in
    #"Другие удаленные столбцы"

Sub BlockRedFontCells()
    Dim ws As Worksheet
    Dim cell As Range
    Dim today As Date
    Dim twoDaysAgo As Date
    Dim lastRow As Long
    Dim rowRange As Range
    
    ' Устанавливаем рабочий лист
    Set ws = ThisWorkbook.Sheets("База")
    
    ' Получаем текущую дату
    today = Date
    twoDaysAgo = today - 2
    
    ' Находим последнюю непустую ячейку в столбце A
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    ' Сначала разблокируем все ячейки
    ws.Unprotect Password:="ваш_пароль" ' Установите свой пароль
    ws.Cells.Locked = False
    
    ' Проходим по диапазону A2 до последней непустой ячейки
    For Each cell In ws.Range("A2:A" & lastRow)
        ' Проверяем, если дата в ячейке меньше двух суток от сегодняшней
        If Not IsEmpty(cell) Then
            If cell.Value <= twoDaysAgo Then
                ' Определяем диапазон всей строки
                Set rowRange = ws.Range(cell, cell.Offset(0, 9)) ' A:J
                
                ' Меняем цвет шрифта на темно-красный для всей строки
                rowRange.Font.Color = RGB(139, 0, 0) ' Темно-красный цвет
                
                ' Блокируем всю строку, если шрифт красный
                If rowRange.Font.Color = RGB(139, 0, 0) Then
                    rowRange.Locked = True
                End If
            End If
        End If
    Next cell
    
    ' Защита листа
    ws.Protect Password:="ваш_пароль" ' Установите свой пароль
End Sub

Sub Кнопка6_Щелчок()
  Dim myRange As Range
    Set myRange = Range("Пи")
    Dim numRows As Long
    numRows = myRange.Rows.Count
    
    If numRows >= 2 Then
        'Delete second-to-last row in range
        myRange.Rows(numRows - 1).Delete Shift:=xlUp
    Else
        'Range has 1 or 0 rows, can't delete second-to-last row
        MsgBox "Range has 1 or 0 rows, can't delete second-to-last row."
    End I

Sub Кнопка7_Щелчок()
Dim myRange As Range
    Set myRange = Range("Пи")
    Dim numRows As Long
    numRows = myRange.Rows.Count

    'Insert new row as second-to-last row in range
    If numRows >= 2 Then
        myRange.Rows(numRows - 1).Insert Shift:=xlDown
        'Copy formatting from above row to new row
        myRange.Rows(numRows - 2).Copy
        myRange.Rows(numRows - 1).PasteSpecial Paste:=xlPasteFormats
    Else
        'Range has fewer than 2 rows, so we can't insert a new row
        MsgBox "Range has fewer than 2 rows, can't insert new row."
    End If
    Application.CutCopyMode = False 'Clear clipboard
End Sub

Sub HideColumnsIfContainSHTC4()
    Dim i As Long
    Dim cell As Range
        
    For i = 1 To ActiveSheet.UsedRange.Columns.Count
        For Each cell In ActiveSheet.Range(Cells(1, i), Cells(ActiveSheet.UsedRange.Rows.Count, i)).Cells
            If InStr(cell.Value, "ШтЧ") > 0 And cell.Value <> "Итог   ШтЧ" Then
                ActiveSheet.Columns(i).EntireColumn.Hidden = True
                Exit For
            End If
        Next cell
    Next i
End Sub