Kopieren aus dateien in eine neue

Sub alle_Dateien_Verzeichnis() '
Dim dlg As FileDialog
Dim Si, Ext$, Datei$, TBN, CC&, LR&, LC&, tmp%
Dim Name1$, Name2$
Name1 = "Tabelle1"
Name2 = "Kalkulation"
Set TBN = ActiveWorkbook.Sheets(Name1)
Set dlg = Application.FileDialog(msoFileDialogFolderPicker) 'Verzeichnis wählen
On Error GoTo Fehler
If dlg.Show = True Then
For Each Si In dlg.SelectedItems 'Die Abfrage für den selektierten Eintrag
Ext = "*.xls"       'Dateiextension ggf. anpassen
Datei = Dir(Si & "\" & Ext) 'Name der ersten Datei
LR = TBN.Cells.SpecialCells(xlCellTypeLastCell).Row 'Letzte Zeile des gesamten  _
Blattes
CC = TBN.Cells(LR, 256).End(xlToLeft).Column     'letzte Spalte einer Zeile
If CC = 1 Then CC = 0 'Wenn Tabelle noch leer
LC = TBN.Cells(Rows.Count, CC + 1).End(xlUp).Row 'letzte Zeile der Spalte
If LC  LR Then LR = LC
If LR = 1 Then LR = 0 'Wenn Tabelle noch leer
tmp = 0
Do
If tmp = 3 Then LR = LR + 18
If tmp = 3 Then tmp = 0
Application.ScreenUpdating = False
Workbooks.Open Filename:=Si & "\" & Datei
With Workbooks(Datei).Sheets(Name2)
TBN.Cells(LR + 1, tmp * 5 + CC + 1) = Datei
TBN.Cells(LR + 2, tmp * 5 + CC + 1) = .Range("B2")
TBN.Cells(LR + 3, tmp * 5 + CC + 1) = .Range("B4")
TBN.Cells(LR + 4, tmp * 5 + CC + 1) = .Range("B5")
.Range("Q396:U409").Copy
TBN.Cells(LR + 5, tmp * 5 + CC + 1).PasteSpecial Paste:=xlPasteValues
End With
CC = TBN.Cells(LR + 5, 256).End(xlToLeft).Column
If CC = 15 Then CC = 0: LR = LR + 18
Workbooks(Datei).Close SaveChanges:=False 'schließen ohne speichern
Datei = Dir() ' nächste Datei
Loop While Len(Datei) > 0
Next
End If
Fehler:
If Err.Number  0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub

Könnt ihr mir helfen?
Bei mir klappts mit den werden nicht , da Makros und Vlookup verknüpfungen in der Quelldatei sind!
Danke