02.03.2023   Клиент1 1/1, Клиент2 1/, Клиент3 1/

02.03 Клиент1 1/1, Клиент2 1/0, Клиент3 1/0

Sub CopyReports()
    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 "Отчет успешно скопирован!" , vbInformation
    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
    Dim columnNames As Variant ' Массив с именами столбцов
     
    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
         
        ' Заполняем массив с именами столбцов
        ReDim columnNames(1 To UBound(arr, 2))
        For xx = 2 To UBound(arr, 2)
            columnNames(xx) = ra.Cells(1, xx).value
        Next xx
         
        isFirstDate = True
        For yy = 2 To UBound(arr, 1)
            If Not isFirstDate Then
                txt = txt & vbCrLf ' Перенос строки перед каждой датой
            Else
                isFirstDate = False
            End If
             
            ' Изменяем формат даты на "ДД.ММ"
            txt = txt & Format(arr(yy, 1), "dd.mm")
             
            For xx = 2 To UBound(arr, 2)
                Dim value As Variant
                value = arr(yy, xx)
                 
                ' Проверяем, является ли значение после "/" числом
                If InStr(1, value, "/") > 0 Then
                    Dim parts As Variant
                    parts = Split(value, "/")
                     
                    ' Проверяем, является ли вторая часть (после "/") числом
                    If IsNumeric(parts(1)) Then
                        ' Добавляем имя клиента и значение
                        txt = txt & " " & columnNames(xx) & " " & value & ","
                    Else
                        ' Добавляем имя клиента и значение с "0" в конце
                        txt = txt & " " & columnNames(xx) & " " & parts(0) & "/0" & ","
                    End If
                Else
                    If Not IsEmpty(value) Then
                        txt = txt & " " & value
                    End If
                End If
            Next xx
             
            ' Удаление лишней запятой в конце строки
            If Right(txt, 1) = "," Then
                txt = Left(txt, Len(txt) - 1)
            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

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

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 & ","
            Else
                isFirstDate = False
            End If
            
            ' Изменяем формат даты на "ДД.ММ"
            txt = txt & " " & Format(arr(yy, 1), "dd.mm")
            
            For xx = 2 To UBound(arr, 2)
                Dim value As Variant
                value = arr(yy, xx)
                
                ' Проверяем, является ли значение после "/" числом
                If InStr(1, value, "/") > 0 Then
                    Dim parts As Variant
                    parts = Split(value, "/")
                    
                    ' Проверяем, является ли вторая часть (после "/") числом
                    If IsNumeric(parts(1)) Then
                        txt = txt & " " & value
                    Else
                        txt = txt & " " & parts(0) & "/0"
                    End If
                Else
                    txt = txt & " " & value
                End If
            Next xx
        Next yy
    Next ra
    
    GetText = Trim(Mid(txt, 2))
End Function

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

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

Отчет за смену 04.03.2023,  , Клиент Заказы, Клиент_1 1/2, Клиент_2 1/1, Клиент_3 1/1, Клиент_4 1/2,

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

Клиент_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

Private Sub Worksheet_Change(ByVal Target As Range)Dim cell As Range, ra As Range    Application.ScreenUpdating = False
    Set ra = Range([C2], Range("C" & Rows.Count).End(xlUp))
For Each cell In ra.Cells
    If Len(cell) Then
    cell.Hyperlinks.Add cell, cell
End If    
Next cell
    Application.ScreenUpdating = True
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