Ir ao conteúdo
  • Cadastre-se
Sincero16

Excel corrigir erro na Do While

Recommended Posts

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

Compartilhar este post


Link para o post
Compartilhar em outros sites

Crie uma conta ou entre para comentar

Você precisar ser um membro para fazer um comentário

Criar uma conta

Crie uma nova conta em nossa comunidade. É fácil!

Crie uma nova conta

Entrar

Já tem uma conta? Faça o login.

Entrar agora





Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas publicações sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

×