Excel Encerrar a função DO (loop) com uma condição IF

[Willykz]

Elaborei uma macro de ir verificando linha a linha até o final (G1). Todavia, quando ela chega no G1 para a macro com um erro não finalizando a sequência de comandos restante.

Há alguma maneira de usar o Exit Do com uma condição ou Loop com condição de maneira que não interfira no funcionamento do Loop?

Macro: 

 

Range("G4000").Select

Do
        If ActiveCell <> "" Then 'Se célula ativa é diferente de vazio
        ActiveSheet.Cells(ActiveCell.Row, ActiveCell.Column + 1).Select 'seleciona célula da direita
        Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 'inserir uma célula e mover para direita
        ActiveSheet.Cells(ActiveCell.Row, ActiveCell.Column - 2).Select 'retorna para a célula da data
        ActiveCell.Copy 'copia a célula data
        ActiveSheet.Cells(ActiveCell.Row, ActiveCell.Column + 2).Select 'seleciona célula da direita
        Selection.PasteSpecial xlPasteValuesAndNumberFormats 'cola a data
        Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 'inserir uma célula e mover para direita
        ActiveSheet.Cells(ActiveCell.Row, ActiveCell.Column - 1).Select 'volta para a célula do PROCV
        ActiveCell.Copy 'copia PROCV
        ActiveSheet.Cells(ActiveCell.Row, ActiveCell.Column + 1).Select  'volta para a célula após cópia data
        Selection.PasteSpecial xlPasteValuesAndNumberFormats  'cola PROCV
        ActiveSheet.Cells(ActiveCell.Row, ActiveCell.Column - 1).Select  'retorno para a linha principal do macro
        ActiveSheet.Cells(ActiveCell.Row - 1, ActiveCell.Column).Select  'seleciona célula acima
                   
        Else
        
       
        ActiveSheet.Cells(ActiveCell.Row - 1, ActiveCell.Column).Select  'seleciona célula acima
        
                      
        End If
        
        Loop

[Midori]

@Willykz  Se anexar a planilha vai ficar mais fácil ajudar, mas esse erro deve ser porque o loop tenta selecionar linha < 1.

 

Se for isso você pode colocar esta condição no loop,

 

Do While ActiveCell.Row > 1

Loop

 

[Visitante]

'O seu código corrigido.
...

        ActiveSheet.Cells(ActiveCell.Row, ActiveCell.Column - 1).Select  'retorno para a linha principal do macro
        'ActiveSheet.Cells(ActiveCell.Row - 1, ActiveCell.Column).Select  'seleciona célula acima    
        'Else
        End If

        If ActiveCell.Row = 1 Then Exit Do
        ActiveSheet.Cells(ActiveCell.Row - 1, ActiveCell.Column).Select  'seleciona célula acim  
        Loop

...

 

Ou utilize o código abaixo.

Sub ReplicaValores()
 Dim r As Range, c As Range
  Application.ScreenUpdating = False
  ActiveSheet.AutoFilterMode = False
   [F1:G1].AutoFilter 2, "<>"
   Set r = Intersect(Columns(7), [F1].CurrentRegion).SpecialCells(xlCellTypeVisible)
  ActiveSheet.AutoFilterMode = False
  For Each c In r
   c.Offset(, 1).Resize(, 2).Insert Shift:=xlToRight
   c.Offset(, 2).Value = c.Offset(, -1).Value: c.Offset(, 1).Value = c.Value
  Next c
End Sub

 

[Willykz]

1 hora atrás, Midori disse:

Do While ActiveCell.Row > 1 Loop

Este supriu bem minha necessidade.

 

27 minutos atrás, osvaldomp disse:

'O seu código corrigido.
...

        ActiveSheet.Cells(ActiveCell.Row, ActiveCell.Column - 1).Select  'retorno para a linha principal do macro
        'ActiveSheet.Cells(ActiveCell.Row - 1, ActiveCell.Column).Select  'seleciona célula acima    
        'Else
        End If

        If ActiveCell.Row = 1 Then Exit Do
        ActiveSheet.Cells(ActiveCell.Row - 1, ActiveCell.Column).Select  'seleciona célula acim  
        Loop

...

 

Ou utilize o código abaixo.

Sub ReplicaValores()
 Dim r As Range, c As Range
  Application.ScreenUpdating = False
  ActiveSheet.AutoFilterMode = False
   [F1:G1].AutoFilter 2, "<>"
   Set r = Intersect(Columns(7), [F1].CurrentRegion).SpecialCells(xlCellTypeVisible)
  ActiveSheet.AutoFilterMode = False
  For Each c In r
   c.Offset(, 1).Resize(, 2).Insert Shift:=xlToRight
   c.Offset(, 2).Value = c.Offset(, -1).Value: c.Offset(, 1).Value = c.Value
  Next c
End Sub

Os dois códigos também me atenderam. Obrigado pela ajuda.