Excel corrigir erro na Do While

[Sincero16]

Ola pessoal estou trabalhando nessa macro que preciso abrir vários arquivos no Excel e copiar os dados da colunas A2 e B2 que possuem dados

de todas planilhas porém tem alguns possuem mais planilhas que outros programei e ele funciona porém estou com problema na Do While pois eu programei para se em uma planilha que não tenha valores para ir para a próxima planilha, no entanto quando chega na ultima planilha da erro.

Agradeço a Ajuda abaixo esta o código  

Private Sub BtPlaca_Click()

Dim FSO         As Object
Dim Pasta       As String
Dim Planilha    As Object
Dim OpenBook    As String
Dim UltCel      As Range
Dim W           As Worksheet
Dim x           As Integer

'Achar útima celula
Set UltCel = Range("A1048576").End(xlUp)
UltCel.Select
ActiveCell.Offset(1, 0).Select

Set FSO = CreateObject("Scripting.FileSystemObject")
Pasta = "C:\Users\Desktop\Base\"
'Pasta com as planilhas que serão abertas e copiadas

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

For Each Planilha In FSO.GetFolder(Pasta).Files

If InStr(1, Planilha, ".xls") = 0 Then GoTo PRÓXIMO

Workbooks.Open (Planilha)
OpenBook = ActiveWorkbook.Name

'Verificar se Branco ""
'Do While ActiveCell.Range("a2").Value <> ""
For A = 1 To Sheets.Count
Do While ActiveCell.Range("a2").Value <> ""
Sheets(A).Select
Sheets(A).Range("A2").Select

'código para copiar
 ActiveSheet.Range("a2:" & ActiveSheet.Range("b2"). _
    End(xlDown).Address).Select
    Selection.Copy

'ativar o arquivo de onde os dados foram copiados

   Windows(ThisWorkbook.Name).Activate
    ActiveCell.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
  False, Transpose:=False
 Application.CutCopyMode = False

'Ativar depois ultima celula
Range("A2").Select
Set UltCel = Range("A1048576").End(xlUp)
UltCel.Select
ActiveCell.Offset(1, 0).Select

Windows(ThisWorkbook.Name).ActivateNext
ActiveSheet.Next.Select
   Loop
    Next

PRÓXIMO:
Next

Application.ScreenUpdating = True

MsgBox "Dados Copiados com Sucesso!", vbInformation, "Aviso"

Application.Calculation = xlCalculationAutomatic

End Sub