ERRO DE ESTOURO NO VBA

F4B1NH0 01/09/2015 17:33:09
#450829
Boa tarde pessoal!

Fiz uma macro simples que copia da sheet [Ô]Atualizado[Ô] para a sheet [Ô]Histórico[Ô] se a data estiver vencida.
Até ae tudo bem, o problema é que se na aba Atualizado existir somente 1 registro, na hora que rodo a macro ele apresenta o erro de Estouro

E se tiver 2 ou mais registros na aba Atualizados, ele funciona normalmente.

Alguém pode me da uma luz do que está ocorrendo?
Segue em anexo a planilha que eu fiz
F4B1NH0 01/09/2015 18:19:07
#450835
Desculpem, segue novamente a planilha sem o bloqueio no VBA

Código que eu fiz:


  Sub copiar_promomemo()

Dim data As Date
data = Date
Dim teste As Integer
For Each celulas In Sheets([Ô]Atualizado[Ô]).Range([Ô]H8:H1000[Ô])
                                    
 
 If celulas.Value <> [Ô][Ô] Then
If Int(celulas) < data Then


celulas.EntireRow.Copy
Sheets([Ô]Historico[Ô]).Select
Range([Ô]f6[Ô]).End(xlDown).Offset(1, 0).Select
Selection.EntireRow.PasteSpecial


End If
End If

Next
Dim rng As Range, i As Integer
Sheets([Ô]Atualizado[Ô]).Select
Set rng = Sheets([Ô]Atualizado[Ô]).Range([Ô]h8[Ô], ActiveSheet.Range([Ô]h8[Ô]).End(xlDown))
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value < data Then rng.Cells(i).EntireRow.Delete
Next

End Sub
DS2T 01/09/2015 18:36:22
#450837 
Sub copiar_promomemo()

Dim data As Date
data = Date
Dim teste As Integer
For Each celulas In Sheets([Ô]Atualizado[Ô]).Range([Ô]H8:H1000[Ô])
                                    
 
 If celulas.Value <> [Ô][Ô] Then
If Int(celulas) < data Then


celulas.EntireRow.Copy
Sheets([Ô]Historico[Ô]).Select
Range([Ô]f6[Ô]).End(xlDown).Offset(1, 0).Select
Selection.EntireRow.PasteSpecial


End If
End If

Next
Dim rng As Range, i As Integer
Sheets([Ô]Atualizado[Ô]).Select
If Sheets([Ô]Atualizado[Ô]).Range([Ô]H8[Ô]).Text = [Ô][Ô] Then Exit Sub
Set rng = Sheets([Ô]Atualizado[Ô]).Range([Ô]h8[Ô], ActiveSheet.Range([Ô]h8[Ô]).End(xlDown))
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value < data Then rng.Cells(i).EntireRow.Delete
Next

End Sub



Use isso... o problema está em usar o método .End(xlDown) quando a célula está vazia e todas abaixo também tem. Ele vai pra última linha do Excel que estou a variavel Integer. Você poderia usar um long, mas ele ia travar o loop durante um bom tempo... por nada.
Aí basta você fazer uma condição pra ver se tem algo dentro da célula e meter um Exit Sub.

Além do mais, não diria que esse é o melhor método para fazer o que está fazendo. Mas seja como for, está aí arrumado.
F4B1NH0 02/09/2015 09:22:06
#450865
Obrigado DS2T!!!
Aqui continua dando o erro de estouro

se não tiver muito ocupado, pode explicar como vc faria essa macro?
Não sou muito bom com lógica, como vc pode ver, ae iria usar o seu [Ô]jeito[Ô] pra entender a diferença

Obrigado!!
F4B1NH0 02/09/2015 14:02:57
#450894
Consegui fazer aqui!!

Segue o código correto caso alguém precise, eu mudei a forma de apagar os dados, na última parte do código.


  Sub copiar_promomemo()

Dim data As Date
data = Date
Dim teste As Integer
For Each celulas In Sheets([Ô]Atualizado[Ô]).Range([Ô]H8:H1000[Ô])
                                    
 If celulas = [Ô][Ô] Then Exit For
 If celulas <> [Ô][Ô] Then
 If Int(celulas) < data Then



celulas.EntireRow.Copy
Sheets([Ô]Historico[Ô]).Select
Range([Ô]f6[Ô]).End(xlDown).Offset(1, 0).Select
Selection.EntireRow.PasteSpecial


End If
End If

Next
Dim i As Integer

For i = 8 To 200
Sheets([Ô]Atualizado[Ô]).Select
Cells(i, 8).Select
If Cells(i, 8) = [Ô][Ô] Then Exit Sub
        If Selection.Value < data Then
            Selection.EntireRow.Delete
           i = i - 1
    End If
    Next i
End Sub

Tópico encerrado , respostas não são mais permitidas
Voltar