Sub tt()
    Dim a, i&, ii&, s$
    
    With [c1].CurrentRegion
    a = .Value: .Clear
    End With
    
    With GetObject("New:{EE09B103-97E0-11CF-978F-00A02463E06F}")
    For i = 1 To UBound(a)
    s = a(i, 1)
    If .exists(s) Then
    a(.Item(s), 2) = a(.Item(s), 2) + a(i, 2)
    Else
    ii = ii + 1: .Item(s) = ii
    a(ii, 1) = a(i, 1): a(ii, 2) = a(i, 2)
    End If
    Next
    End With
    
    [c1].Resize(ii, 2) = a
End Sub

a(ii, 1) = "'" & a(i, 1)

For i = Nomer_Str_I To Col_I
    If Stop_Pr Then
        Exit For
    End If
    Arr_I(1, i) = i
    Arr_I(2, i) = Ran(CInt(i), CInt(Nomer_Col_I))
    Arr_I(3, i) = CDbl(Ran(CInt(i), CInt(Nomer_I_X)))
    Arr_I(4, i) = Ran(CInt(i), CInt(Nomer_Col_I) + 2)
    Sh = Sh + 1
    Call Toolbar(CInt(Sh), CInt(Sh_Ob))
Next i

For i = Nomer_Str_I To Col_I
    For j = i + 1 To Col_I
        If Arr_I(2, i) = Arr_I(2, j) And Arr_I(2, i) <> "0" Then
            Sum = Sum + CDbl(Arr_I(3, j))
            Arr_I(0, j) = "1"
            Check = True
        End If
    Next j
    If Check Then
        Range(Cells(i, CInt(Nomer_I_X)), Cells(i, CInt(Nomer_I_X))).Value = CDbl(Arr_I(3, i)) + Sum
        Check = False
        Sum = 0
    End If
    Sh = Sh + 1
    Call Toolbar(CInt(Sh), CInt(Sh_Ob))
Next i

For i = Col_I To Nomer_Str_I Step -1
    If Arr_I(0, i) = "1" Then
        Rows(i).Delete
     End If
    Sh = Sh + 1
    Call Toolbar(CInt(Sh), CInt(Sh_Ob))
Next i

Option Explicit
Dim Col As Integer
Dim s As String
Dim wb As Workbook
Dim Name_Wb As String
Public Stop_Pr As Boolean

Function Ran(i As Integer, j As Integer) As String
    If Range(Cells(i, j), Cells(i, j)).Text = "" Then
        Ran = 0
    Else
        Ran = Range(Cells(i, j), Cells(i, j)).Value
    End If
End Function

Private Sub Wb_Books()
    Col = 0
    s = ""
    For Each wb In Workbooks
    Col = Col + 1
        If wb.Name = "" Then
           wb.Close True
        Else
            Name_Wb = wb.Name
            s = s + Name_Wb + " =  " + Str(Col) + vbCrLf
        End If
    Next wb
End Sub

Sub Toolbar(k As Integer, Full As Integer)
    With UserForm1
        .Frame1.Caption = "Процесс " + Str(k) + " /" + Str(Full)
        .Label2.Caption = Str(100 * Round(k / Full, 2)) + "%"
        .Label2.Width = Int(200 * (k / Full))
    End With
    DoEvents
End Sub

Sub Base()
Dim Name_Wb_I, Name_Wb_J As String
Dim Col_I, Col_J As Integer
Dim Nomer_Str_I, Nomer_Col_I, Nomer_I_X, Nomer_Str_J, Nomer_Col_J, Nomer_J_X, Nomer_J_X1 As Integer
Dim i, j As Integer
Dim Num, S1, S2 As String
Dim Arr_I(4, 17000) As String
Dim Check As Boolean
Dim Sum, Sum1 As Double
Dim Sh, Sh_Ob As Integer

Name_Wb_I = Workbooks.Item(Int(InputBox(s, "Выбрать номер книги"))).Name
Workbooks.Item(Name_Wb_I).Activate
Range(Cells(1, 1), Cells(1, 1)).Select
Col_I = Cells(Rows.Count, 2).End(xlUp).Row
Nomer_Str_I = Int(InputBox("Введите номер строки по которому будет идти сверка", "Окно ввода по реєстру для книги " + Name_Wb_I))
Nomer_Col_I = Int(InputBox("Введите номер колонки по которому будет идти сверка", "Окно ввода по реєстру для книги " + Name_Wb_I))

Nomer_I_X = Int(InputBox("Введите номер колонки начала записи данных", "Окно ввода по реєстру"))

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayStatusBar = False
  
Workbooks.Item(Name_Wb_I).Activate

Sh_Ob = Col_I - (Nomer_Col_I - 1)
Sh = 0
For i = Nomer_Str_I To Col_I
    If Stop_Pr Then
        Exit For
    End If
    Arr_I(1, i) = i
    Arr_I(2, i) = Ran(CInt(i), CInt(Nomer_Col_I))
    Arr_I(3, i) = CDbl(Ran(CInt(i), CInt(Nomer_I_X)))
    Arr_I(4, i) = Ran(CInt(i), CInt(Nomer_Col_I) + 2)
    Sh = Sh + 1
    Call Toolbar(CInt(Sh), CInt(Sh_Ob))
Next i

Check = False
Sum = 0
Stop_Pr = False
Sh = 0
For i = Nomer_Str_I To Col_I
    For j = i + 1 To Col_I
        If Arr_I(2, i) = Arr_I(2, j) And Arr_I(2, i) <> "0" Then
            Sum = Sum + CDbl(Arr_I(3, j))
            Arr_I(0, j) = "1"
            Check = True
        End If
    Next j
    If Check Then
        Range(Cells(i, CInt(Nomer_I_X)), Cells(i, CInt(Nomer_I_X))).Value = CDbl(Arr_I(3, i)) + Sum
        Check = False
        Sum = 0
    End If
    Sh = Sh + 1
    Call Toolbar(CInt(Sh), CInt(Sh_Ob))
Next i
Sh = 0
For i = Col_I To Nomer_Str_I Step -1
    If Arr_I(0, i) = "1" Then
        Rows(i).Delete
     End If
    Sh = Sh + 1
    Call Toolbar(CInt(Sh), CInt(Sh_Ob))
Next i

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayStatusBar = True

End Sub

Sub Макрос6()

Call Wb_Books
UserForm1.Show
Call Base
End Sub

Sub Макрос2()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    't = Timer
    Set r1 = Range(Cells(1, 3), Cells(1, 3).End(xlDown))
    Set r2 = r1.Offset(0, 1)
    shn = ActiveSheet.Name
    adr2 = "'" & shn & "'!" & r2.Address(ReferenceStyle:=xlR1C1)
        Sheets.Add.Activate
            With Range("C1").Resize(r1.Count, 1)
                .Value = r1.Value
                .RemoveDuplicates Columns:=1, Header:=xlNo
            End With
            With Range(Cells(1, 3), Cells(1, 3).End(xlDown)).Offset(0, 1)
                adr1 = .Offset(0, -1).Address(ReferenceStyle:=xlR1C1)
                .FormulaR1C1 = "=SUMIF(" & adr1 & ",RC[-1]," & adr2 & ")"
                .Value = .Value
            End With
        'Sheets(shn).Delete
        'ActiveSheet.Name = shn
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'MsgBox Format(Timer - t, "0.00000") & "sec"
End Sub