Sub Экспорт()
    SavePath = ""
    With Application.FileDialog(msoFileDialogSaveAs)
        .InitialFileName = ""
        .FilterIndex = 11
        If .Show = -1 Then
            SavePath = .SelectedItems(1)
        End If
    End With
    If SavePath = "" Then Exit Sub
    Dim cell As Range
    Open SavePath For Output As #1
    For Each cell In ActiveSheet.UsedRange
        If Not IsEmpty(cell) Then
            Print #1, cell
        End If
    Next
    Close #1
End Sub

sub M_Doober()
    Dim Sh As Worksheet, Sh1 As Worksheet, kol As Integer, Art As String
    Set Sh = ThisWorkbook.Worksheets("ИП")
    Set Sh1 = ThisWorkbook.Worksheets("Результат")
    Sh1.UsedRange.ClearContents
    LastRow = Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row
    dx = Sh.Range("A1:G" & LastRow)
    With CreateObject("scripting.dictionary")
        For n = 2 To UBound(dx)
            If dx(n, 5) <> "" Then
                If dx(n, 5) < 0 Then
                    kol = Abs(dx(n, 5))
                    For i = n + 1 To UBound(dx)
                        If dx(i, 7) > kol Then
                            Art = dx(i, 2)
                            .Item(Art) = kol
                            Exit For
                        End If
                    Next
                End If
            End If
        Next
        keys = .keys
        If .Count > 0 Then
            Sh1.Range("a2").Resize(.Count, 2) = Application.Transpose(Array(.keys, .Items))
        End If
    End With
End Sub

Sub Макрос1()
    Dim Sh As Worksheet, Key As String, rng As Range
    Set Sh = ActiveSheet
    LastRow = Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row
    Set C_is = CreateObject("scripting.dictionary")
    Set C_DoDel = CreateObject("scripting.dictionary")
    dx = Sh.Range("A1").Resize(LastRow, 9)
    For n = 2 To UBound(dx)
        Key = dx(n, 2) & "_" & dx(n, 9)
        If dx(n, 9) <> "" Then
            If C_is.Exists(Key) Then
                C_DoDel.Item(n) = n
                a = C_is.Item(Key)
                a(0) = a(0) + dx(n, 5)
                a(1) = a(1) & Chr(10) & dx(n, 6)
                C_is.Item(Key) = a
            Else
                C_is.Item(Key) = Array(dx(n, 5), dx(n, 6), n)
            End If
        End If
    Next
    Items = C_is.Items
    For n = 0 To C_is.Count - 1
        Item = Items(n)
        Sh.Range("E" & Item(2)) = Item(0)
        Sh.Range("F" & Item(2)) = Item(1)
    Next
    Keys = C_DoDel.Keys
    For n = 0 To C_DoDel.Count - 1
        If rng Is Nothing Then
            Set rng = Sh.Rows(Keys(n))
        Else
            Set rng = Union(rng, Sh.Rows(Keys(n)))
        End If

    Next
    If Not rng Is Nothing Then rng.Delete

End Sub