Abrir todos los excel de las carpetas y sub

Necesito crear una macro que abra uno por uno todos los archivos que encuentre en la siguiente ruta:

C:\Users\pedro\Desktop\PROYEC\02.- PC Zona Centro\

Al abrir el archivo se harán algunas modificaciones y lo cerrara.

El problema es que hay archivos que están en subcarpetas y no los abre.

Adjunto macro que utilizo:

Sub SSPP_2016()

Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim NRow As Long, ultima As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range
Set SummarySheet = ThisWorkbook.Worksheets(1)
'INDICAR LA RUTA DONDE ESTAN LOS ARCHIVOS (ACCESOS DIRECTOS "LNK")
FolderPath = "C:\Users\pedro\Desktop\PROYEC\02.- PC Zona Centro\"
FileName = Dir(FolderPath & "*.lnk")
'ABRIR LOS ARCHIVOS DE UNO EN UNO
Do While FileName <> ""
Set WorkBk = Workbooks.Open(FolderPath & FileName)
'PASAR LOS DATOS DE UNA HOJA A LA HOJA EN COMUN
ultima = Range("A" & Rows.Count).End(xlUp).Row
If ultima < 5 Then ultima = 5
NRow = SummarySheet.Range("A" & Rows.Count).End(xlUp).Row + 1
Set SourceRange = WorkBk.Worksheets(1).Range("A3:CO" & ultima)
Set DestRange = SummarySheet.Range("A" & NRow)
SourceRange.Select
Selection.Copy
ThisWorkbook.Activate
Worksheets(1).Select
Range("A" & NRow).Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
NRow = NRow + DestRange.Rows.Count
WorkBk.Close savechanges:=False
FileName = Dir()
Loop

End sub