Zellen kopieren makro läuft nicht

Sub Zeileneinlesen()
Dim oFS As Object, oFLDR As Object, oFILE As Object
Dim lRow As Long
Dim wsMy As Worksheet, lngZeile As Long, lngLetzte As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set oFS = CreateObject("scripting.filesystemobject")
lRow = 3
Set oFLDR = oFS.getfolder("\\Server04\av\SharePoint_Beschlaglisten")
For Each oFILE In oFLDR.Files
If oFILE Like "*.xls" Then
lRow = lRow
Workbooks.Open oFILE
End If
For Each wsMy In Worksheets
If wsMy.Name Like "BL_*" Then
wsMy.Activate
ActiveSheet.Range("2:2").Copy
ThisWorkbook.Worksheets(1).Cells(lRow, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,  _
SkipBlanks _
:=False, Transpose:=False
lRow = lRow + Range("2:2").Rows.Count
Next
End If
ActiveWorkbook.Close savechanges:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Next
End Sub