Bom dia!!

Use a pesquisa do fórum!!!

Sub FiltrarAleVBA()
    Dim rngToCopy As Range
    Dim Get_Rows As Long
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
      
    With Worksheets("Plan1")
        Get_Rows = .Range("A65536").End(xlUp).Row
        .Range("A2:D" & Get_Rows).AutoFilter Field:=1, Criteria1:="x"
        Set rngToCopy = Nothing
        Set rngToCopy = .Range("A2:D" & Get_Rows).SpecialCells(xlCellTypeVisible)
        If Not rngToCopy Is Nothing Then rngToCopy.Copy Worksheets("Plan2").Range("A2")
        .ShowAllData
    End With
     
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
End Sub

Olá alexandre,

A macro está copiando as linhas e não movendo!!!!

Boa noite!!

Até onde sei, ou é Copiar ou Recortar!!!!!!!!

Sub FiltrarAleVBA()
    Dim rngToCopy As Range
    Dim Get_Rows As Long
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
      
    With Worksheets("Plan1")
        Get_Rows = .Range("A65536").End(xlUp).Row
        .Range("A2:D" & Get_Rows).AutoFilter Field:=1, Criteria1:="x"
        Set rngToCopy = Nothing
        Set rngToCopy = .Range("A2:D" & Get_Rows).SpecialCells(xlCellTypeVisible)
        If Not rngToCopy Is Nothing Then rngToCopy.Cut Worksheets("Plan2").Range("A2") '<- Veja se funciona
        .ShowAllData
    End With
     
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
End Sub

Apareceu uma mensagem de erro:
Erro em tempo de execução '1004':
O comando escolhido não pode ser executado com várias seleções.
Selecione apenas um intervalo e clique no comando novamente.

Aprendi que 'MOVER = RECORTAR + COLAR', por isso usei o termo!!!

Boa noite!!

Quando se move um intervalo ou célula no excel e não em VBA, sempre é na mesma planilha (Guia)!!!

Eu não tive problemas com meu exemplo!!!!!!

Poste seu arquivo compactado

Att

Segue arquivo.

Boa noite!!

Veja o anexo!!

Caso queira que os dados fiquem em baixo uns dos outros veja em:
viewtopic.php?f=21&t=9027

Att

Alexandre,

Não está funcionando. Realmente a segunda macro coloca os dados um embaixo do outro. Mas também coloca abaixo todos os demais registros. Além disso, troca o nome de Plan2!A1 e apaga os títulos das colunas na linha 2.

Fiquei duas semanas tentando e não consegui.

Admito que sou muito ruim em VBA.

Na planilha anexa abaixo existem dois botões com alterações das sugestões do alexandrevba.

O código do botão 1 é perfeito ao ser clicado pela primeira vez. ele move toas as linhas selecionadas com X da plan1 para a plan2.

O problema é quando ele é executado pela segunda vez. As linhas que foram movidas na primeira vez são sobrescritas pelas que foram movidas agora.

Acho que só falta um jeito do VBA identificar qual é a primeira linha em branco de plan2 e selecionada como destino.

alguém pode me ajudar????

Veja no anexo se lhe atende

Perfeito Reinaldo!

Muito obrigado!!!

Reinaldo,

Se puder me socorre mais uma vez....

Estou usando o código que vc elaborou. Acontece que na planilha verdadeira (não o exemplo que te mandei) existem 4 sheets (processos adm, processos jud, processos fin, processos log) que podem transferir linhas para uma ÚNICA sheet "processos concluídos".

Então tenho duas opções. Crio 4 subs Sub transfere() (Sub transfere adm(), Sub transfere jud(), etc...) e em cada uma delas altero o "plan1" utilizado no exemplo para o respectivos nomes.

A outra meneira seria ter apenas uma sub e passar a referência da planilha onde estou (activesheet) para o vba. Seria isso?

É fácil de fazê-lo? Pode me ajudar mais uma vez?

Boa tarde!!

Use a pesquisa!
Tente adaptar.
viewtopic.php?f=21&t=9119

Att

Olá,
Experimente:

Sub transfere()
Dim lRow As Long, lastRow As Long, lR As Long, nPlan As String
Application.ScreenUpdating = False
nPlan = ActiveSheet.Name
lastRow = Sheets("Plan1").Cells(Cells.Rows.Count, "B").End(xlUp).Row
Sheets(nPlan).Select
For lR = 3 To lastRow
lRow = Sheets("Plan2").Cells(Cells.Rows.Count, "B").End(xlUp).Row
    If UCase(Cells(lR, 1).Value) = UCase("X") Then
        Range("A" & lR & ":D" & lR).Select
        Selection.Copy
        Sheets("Plan2").Select
        Range("A" & lRow + 1).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Application.CutCopyMode = False

        Sheets(nPlan).Select
        Range("A" & lR & ":D" & lR).ClearContents
    End If
Next
Sheets(nPlan).Select
Range("A3:d" & lastRow).Select
Selection.Sort Key1:=Range("B3"), Order1:=xlAscending, Key2:=Range( _
    "C3"), Order2:=xlAscending, Key3:=Range("D3"), Order3:=xlAscending, _
    Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:= _
    xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, _
    DataOption3:=xlSortNormal
Application.ScreenUpdating = True
MsgBox "Feito"
Sheets(nPlan).Cells(3, "B").Select
End Sub