28.02.2023   1/2   1/1   
02.03.2023   1/1   1/   1/1
04.03.2023         1/   1/1

Sub CopyReport()
    Dim sText As String
    Dim rng As Range
    
    Set rng = Intersect(Selection, ActiveSheet.UsedRange)
    
    If Not rng Is Nothing Then
        sText = GetText(rng)
        CopyText sText ' Вывод в буфер обмена
        'SaveText sText ' Вывод в отдельный файл
        
        MsgBox "Отчет успешно скопирован!"
    Else
        MsgBox "Пожалуйста, выберите диапазон ячеек для копирования.", vbExclamation
    End If
End Sub

Private Sub SaveText(sText As String)
    ' Вывод в отдельный файл
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim sFull As String
    sFull = ThisWorkbook.FullName & ".txt"
    
    With fso.CreateTextFile(sFull, True)
        .WriteLine sText
        .Close
    End With
    
    Shell "explorer.exe """ & sFull & """", 1
End Sub

Private Function GetText(rr As Range) As String
    Dim arr As Variant
    Dim txt As String
    Dim yy As Long
    Dim xx As Long
    Dim ra As Range
    Dim isFirstDate As Boolean
    
    For Each ra In rr.Areas
        If ra.Cells.CountLarge = 1 Then
            ReDim arr(1 To 1, 1 To 1)
            arr(1, 1) = ra.value
        Else
            arr = ra.value
        End If
        
        isFirstDate = True
        For yy = 1 To UBound(arr, 1)
            If Not isFirstDate Then
                txt = txt & vbCrLf
            Else
                isFirstDate = False
            End If
            
            ' Проверяем, является ли область таблицей2
            If ra.Columns.Count > 1 Then
                ' Обработка Таблицы2
                Dim dateValue As Variant
                dateValue = arr(yy, 1)
                
                txt = txt & Format(dateValue, "dd.mm") ' Дата
                
                For xx = 2 To UBound(arr, 2)
                    Dim value As Variant
                    value = arr(yy, xx)
                    
                    If Not IsEmpty(value) Then
                        Dim crmValue As Variant
                        crmValue = ra.Cells(1, xx).Offset(-1).value
                        
                        txt = txt & " " & crmValue & " " & IIf(value = 0, "0", Replace(value, ".", "/"))
                        If xx < UBound(arr, 2) Then
                            txt = txt & ","
                        End If
                    End If
                Next xx
            End If
        Next yy
    Next ra
    
    GetText = Trim(txt)
End Function

Sub CopyText(Text As String)
    'VBA Macro using late binding to copy text to clipboard.
    'By Justin Kay, 8/15/2014
    Dim MSForms_DataObject As Object
    Set MSForms_DataObject = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    MSForms_DataObject.SetText Text
    MSForms_DataObject.PutInClipboard
    Set MSForms_DataObject = Nothing
End Sub

Клиент_1   1/2
Клиент_2   1/1
Клиент_3   1/1
Клиент_4   1/2

Клиент_1 1/2, Клиент_2 1/1, Клиент_3 1/1, Клиент_4 1/2

=COUNTX('Таблица1';'Таблица1'[Доп. продажи])+"/"+COUNTX('Таблица1';'Таблица1'[Сумма])

Sub TableDown()

Application.SendKeys ("^{END}") 'перемещает в низ таблицы

End Sub
Sub TableUp()

Application.SendKeys ("^{HOME}") 'перемещает в верх таблицы

End Sub

With Worksheets
    .Hyperlinks.Add Anchor:=.Range("C:C"), _
    Address:=TextBox3.Value, _
    TextToDisplay:="TextBox2.Value - рабочий сайт"
End With

'Макрос1 - автозаполнение Даты при добавлении информации в Номер заказа
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim WorkRng As Range
    Dim Rng As Range
    Dim xOffsetColumn As Integer
    Application.ScreenUpdating = False
    Set WorkRng = Intersect(Лист1.Range("C:C"), Target)
    xOffsetColumn = -1
    If Not WorkRng Is Nothing Then
        Application.EnableEvents = False
        For Each Rng In WorkRng
            If Not VBA.IsEmpty(Rng.Value) Then
                Rng.Offset(0, xOffsetColumn).Value = VBA.Date
                Rng.Offset(0, xOffsetColumn).NumberFormat = "DD.MM.YYYY"
            Else
                Rng.Offset(0, xOffsetColumn).ClearContents
            End If
        Next
        Application.EnableEvents = True
    End If
End Sub

'Макрос2 - показ пользовательской формы
Sub UserFormShow()
    UserForm1.Show
End Sub

'Макрос3 - автоматическая вставка максимальной даты в фильтр СводнойТаблицы1 (находится рядом на том же листе)
Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
    Dim oTbl As ListObject, maxdate As Date
    Set oTbl = ThisWorkbook.Worksheets("Лист1").ListObjects("Таблица1")
    maxdate = Application.Max(oTbl.ListColumns("Дата").Range)
    Application.EnableEvents = False
    Target.PivotFields("[Таблица1].[Дата].[Дата]").ClearAllFilters
    Target.PivotFields("[Таблица1].[Дата].[Дата]").CurrentPageName = "[Таблица1].[Дата].&[" & Format(maxdate, "YYYY-MM-DD") & "T00:00:00]"
    Application.EnableEvents = True
End Sub