Работа с буфером

'Public Sub SetTextIntoClipboard(ByVal txt As String)
'    Dim MyDataObj As New DataObject
'    MyDataObj.SetText txt
'    MyDataObj.PutInClipboard
'End Sub
 
Sub SetTextIntoClipboard(ByVal txt$) ' Запись в буфер
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .SetText txt$
        .PutInClipboard
    End With
End Sub
 
Sub Extract_Unique()
    Dim vItem, avArr, li As Long
    ReDim avArr(1 To Rows.count, 1 To 1)
    With New Collection
        On Error Resume Next
        For Each vItem In Range("C2:C" & Cells.SpecialCells(xlLastCell).Row)
                .Add vItem, CStr(vItem)
            If Err = 0 And vItem <> "Клиент" And Not IsEmpty(vItem) Then
                li = li + 1: avArr(li, 1) = vItem
            Else: Err.Clear
            End If
        Next
    End With
    If li Then [AO2].Resize(li).Value = avArr
End Sub
 
 
Sub ПлатежнаяДисциплинаВыгрузкаИЗЗенитФакторинг()
 
RowStart = Range("1:30").Find("Номер поставки").Row
LastRow = Cells.SpecialCells(xlLastCell).Row
 
СуммаУступки = Range("1:30").Find("Сумма Уступки").Column
Статус = Range("1:30").Find("Статус").Column
Просрочка = Range("1:30").Find("Просрочка по договору поставки").Column
Отсрочка0 = Range("1:30").Find("Отсрочка").Column
 
Sheepment = 0
Payment = 0
count = 0
For i = RowStart + 1 To LastRow
    If Cells(i, Статус).Value = "Погашена" Then
        Payment = Payment + Cells(i, СуммаУступки)
        count = count + 1
    End If
    Sheepment = Sheepment + Cells(i, СуммаУступки)
 
    СуммаПросрочки = СуммаПросрочки + Cells(i, Просрочка).Value
    'МаксПросрочка
    If Cells(i, Просрочка).Value > МаксПросрочка Then
        МаксПросрочка = Cells(i, Просрочка).Value
    End If
 
    'МаксОтсрочка
    If CInt(Cells(i, Отсрочка0).Value) > CInt(Отсрочка) Then
        Отсрочка = CInt(Cells(i, Отсрочка0).Value)
    End If
 
Next i
 
ИТОГО = GetH1(Payment / Sheepment) * 0.4 + GetH2(СуммаПросрочки / count) * 0.5 + GetH3(Payment / Sheepment) * 0.1
MsgBox "H1=" & Round(Payment / Sheepment, 2) * 100 & "% " & vbNewLine & _
       "H2=" & Round(СуммаПросрочки / count, 2) & " " & vbNewLine & _
       "H3=" & Round(МаксПросрочка / Отсрочка, 2) * 100 & "% " & vbNewLine & _
       "ИТОГО: " & FormatNumber(ИТОГО, 2)
 
      SetTextIntoClipboard "H1=" & Round(Payment / Sheepment, 2) * 100 & "% " & vbNewLine & _
       "H2=" & Round(СуммаПросрочки / count, 2) & " " & vbNewLine & _
       "H3=" & Round(МаксПросрочка / Отсрочка, 2) * 100 & "% " & vbNewLine & _
       "ИТОГО: " & FormatNumber(ИТОГО, 2) & vbNewLine & _
       "Отгружено: " & FormatNumber(Sheepment) & vbNewLine & _
       "Оплачено: " & FormatNumber(Payment) & vbNewLine & _
       "Средняя просрочка: " & FormatNumber(СуммаПросрочки / (i - 3), 2) & vbNewLine & _
       "Максимальная просрочка: " & МаксПросрочка & vbNewLine & _
       "Договорная отсрочка (макс): " & Отсрочка
 
 
End Sub
 
 
 
 
Function GetH1(r As Double) As Integer
    Select Case r
         Case 0.7 To 1: GetH1 = 1
         Case 0.6 To 0.7: GetH1 = 2
         Case 0.5 To 0.6: GetH1 = 3
         Case 0 To 0.5: GetH1 = 4
    End Select
End Function
 
 
Function GetH2(r As Double) As Integer
    Select Case r
         Case -1 To 7: GetH2 = 1
         Case 7 To 15: GetH2 = 2
         Case 15 To 20: GetH2 = 3
         Case 20 To 100: GetH2 = 4
    End Select
End Function
 
Function GetH3(r As Double) As Integer
    Select Case r
         Case -1 To 0.15: GetH3 = 1
         Case 0.15 To 0.4: GetH3 = 2
         Case 0.4 To 0.6: GetH3 = 3
         Case 0.6 To 1: GetH3 = 4
    End Select
End Function