Код VBA с потенциально поврежденными файлами

Question

У меня есть следующий код. Я взял его у MRexcel, похоже, они не заинтересованы в дальнейшей помощи. Я пробовал различные решения без удачи. Я считаю, что некоторые файлы могут быть повреждены таким образом, чтобы макрос не работал должным образом. Это в основном циклический просмотр папки и объединение всех данных в одну электронную таблицу. Он делает две вещи, которые являются неправильными.

1. Он только просматривает отфильтрованные данные в файле. Мне нужно, чтобы он извлекал все данные независимо от фильтра.
2. Он не вытягивает каждый файл в папке, если я беру данные этого файла и сохраняю их в хорошем файле, который действительно проходит, затем данные тянутся просто отлично. Есть ли способ исправить это?

Вот что я имею до сих пор.

Sub combine_multiple_workbooks()
  Dim wb1 As Workbook, wb2 As Workbook, sh1 As Worksheet, sh2 As Worksheet
  Dim sFile As Variant, sPath As String, LastRow1 As Long, LastRow2 As Long
  Dim sh As Worksheet

  Application.ScreenUpdating = False
  Application.DisplayAlerts = False

  Set wb1 = ThisWorkbook
  Set sh1 = wb1.Sheets("Summary")
  sh1.Cells.ClearContents
  sh1.Range("A1").Value = "File"
  sPath = "C:\Users\jordan.burch.ctr\Desktop\TEST\"
  sFile = Dir(sPath & "Phase1*.xls*")
  On Error Resume Next
  Do While sFile <> ""
    Set wb2 = Workbooks.Open(sPath & sFile)

    Workbooks.Open Filename:=sPath & sFile, ReadOnly:=True, IgnoreReadOnlyRecommended:=True, CorruptLoad:=xlExtractData
    For Each sh In wb2.Sheets
      If sh.Visible = -1 Then
        Set sh2 = wb2.Sheets(1)
        Exit For
      End If
    Next
    LastRow2 = sh2.Range("B" & Rows.Count).End(xlUp).Row
    LastRow1 = sh1.Range("B" & Rows.Count).End(xlUp).Row + 1
    sh2.Range("A2:AE" & LastRow2).Copy
    sh1.Range("B" & LastRow1).PasteSpecial xlPasteAll
    sh1.Range("A" & LastRow1).Resize(LastRow2 - 1).Value = sFile

    wb2.Close False
    sFile = Dir()
  Loop
End Sub

Любая помощь очень ценится.