=IFERROR(VLOOKUP(LEFT(A2;FIND(".";A2;4))&"0.0";Лист2.$A$2:$C$11;2;0);"")

Sub CombineWorkbooks()   
  
      
   Dim FilesToOpen   
   Dim x As Integer   
  
   On Error GoTo ErrHandler   
   Application.ScreenUpdating = False   
      
      
  
   FilesToOpen = Application.GetOpenFilename _   
     (FileFilter:="Microsoft Excel Files (*.xls), *.xls", _   
     MultiSelect:=True, Title:="Files to Merge")   
  
   If TypeName(FilesToOpen) = "Boolean" Then   
       MsgBox "Файл не выбран!"   
       GoTo ExitHandler   
   End If   
  
      
   x = 1   
   While x <= UBound(FilesToOpen)   
       Workbooks.Open Filename:=FilesToOpen(x)   
       Sheets().Move After:=ThisWorkbook.Sheets _   
         (ThisWorkbook.Sheets.Count)   
       x = x + 1   
   Wend   
  
ExitHandler:   
   Application.ScreenUpdating = True   
   Exit Sub   
  
ErrHandler:   
   MsgBox Err.Description   
   Resume ExitHandler   
      
End Sub
Sub DeleteLists()
'
' DeleteLists Macros
'

'
    Sheets(Array("Summary", "Slave servers summary")).Select
    Sheets("Slave servers summary").Activate
    ActiveWindow.SelectedSheets.Delete
End Sub
Sub CollectDataFromAllSheets()
    Dim ws As Worksheet
     
    Set wbCurrent = ActiveWorkbook
    Workbooks.Add
    Set wbReport = ActiveWorkbook
     
    'копируем на итоговый лист шапку таблицы из первого листа
    'wbCurrent.Worksheets(1).Range("A1:D1").Copy Destination:=wbReport.Worksheets(1).Range("A1")
     
    'проходим в цикле по всем листам исходного файла
    For Each ws In wbCurrent.Worksheets
     
        'определяем номер последней строки на текущем листе и на листе сборки
        n = wbReport.Worksheets(1).Range("A1").CurrentRegion.Rows.Count
         
        'задаем исходный диапазон, который надо скопировать с каждого листа - на выбор:
        'Set rngData = ws.Range("A1:D5")            'фиксированный диапазон
        'Set rngData = ws.UsedRange                 'все, что есть на листе
        'Set rngData = ws.Range("F5").CurrentRegion    'область, начиная от ячейки F5
        Set rngData = ws.Range("A6", ws.Range("A6").SpecialCells(xlCellTypeLastCell))    'от А6 и до конца листа
         
        'копируем исходный диапазон и вставляем в итоговую книгу со следующей строки
        rngData.Copy Destination:=wbReport.Worksheets(1).Cells(n + 1, 1)
         
    Next ws
End Sub
Sub DeleteColumnAC()
'
' DeleteColumnAC Macros
'

'
    Range("A:A,C:C").Select
    Range("C1").Activate
    Selection.Delete Shift:=xlToLeft
End Sub
Sub RenameColumns()
'
' RenameColumns Macros
'

'
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "id"
End Sub
Sub CopyABtoD()
Dim arr(), arrNew()
Dim I&, J&, N&
With ActiveSheet
arr = .UsedRange.Value
For J = 1 To UBound(arr, 2)
    For I = 1 To UBound(arr, 1)
        If arr(I, J) <> Empty Then
            ReDim Preserve arrNew(N)
            arrNew(N) = arr(I, J)
            N = N + 1
        End If
    Next
Next
.Cells(1, UBound(arr, 2) + 1).Resize(UBound(arrNew) + 1) = Application.Transpose(arrNew)
End With
End Sub
Sub DeleteColumnAB()
'
' DeleteColumnAB Macros
'

'
    Range("A:A,B:B").Select
    Range("B1").Activate
    Selection.Delete Shift:=xlToLeft
End Sub
Sub DelDouble()
'
' DelDouble Macros
'

'
    Columns("A:A").Select
    ActiveSheet.Range("$A$1:$A$8706").RemoveDuplicates Columns:=1, Header:= _
        xlYes
End Sub
Sub startproc()
 CombineWorkbooks
 DeleteLists
 CollectDataFromAllSheets
 DeleteColumnAC
 RenameColumns
 CopyABtoD
 DeleteColumnAB
End Sub

Sub
...
End Sub

=ЕСЛИОШИБКА(ВПР(ЛЕВБ(ПОДСТАВИТЬ($A2;".";".*****";2);9);Лист2!$A$2:$C$999;СТОЛБЕЦ(););"")