Sub КБ3()
    Application.ScreenUpdating = False
    Set wb1 = Application.ActiveWorkbook
    Dim i As Integer
    i = 1
    Dim sFolder As String, sFiles As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    Dim Num&, ii&, Nam$

    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    
    sFiles = Dir(sFolder & "*КБ2.xls")

    With CreateObject("Scripting.Dictionary")
        Do While sFiles <> ""
            Num = CDbl(Split(sFiles, "-")(1))
            .Item(Num) = sFolder & sFiles
             sFiles = Dir
        Loop

       For ii = 1 To .Count
            Num = WorksheetFunction.Small(.keys, ii)
            Nam = .Item(Num)
            Workbooks.Open Nam
            Set wb2 = Application.ActiveWorkbook

                wb1.Sheets(1).Cells(i, 1) = wb2.Sheets(1).Cells(1, 1)
                wb1.Sheets(1).Cells(i, 2) = wb2.Sheets(1).Cells(1, 2)

                i = i + 1

                wb2.Activate
            ActiveWorkbook.Close False
        Next
    End With
    Application.ScreenUpdating = True
End Sub

for x =1 to 1000
 файл = х & "-КБ2.xls*"
   On Error Resume Next
   Проверка  = Dir(fname) <> vbNullString
   If Err.Number <> 0 Then проверка = "существует"
   On Error GoTo 0

Sub tt()
    Dim a()
    a = Sheets(1).[a1].CurrentRegion.Value
    uSort a, 3
    Sheets(1).[e1].Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub



Private Sub uSort(ByRef x(), n&)
' uSort a, 3 - сортировать массив по 3-му столбцу
    Dim v, u&, d&, f%, st&
    If IsArray(x) Then
        f = LBound(x): d = f
        For u = f + 1 To UBound(x)
            If x(u, n) < x(d, n) Then
                For st = LBound(x, 2) To UBound(x, 2)
                    v = x(d, st): x(d, st) = x(u, st): x(u, st) = v
                Next
                u = d - 1: d = u - 1: If u < f Then d = u: u = f
            End If
            d = d + 1
        Next
    End If
End Sub