Este fórum está sendo desativado

[SoNiCCrAzY]

Boa tarde galera, sou novo na area de Macros e VBA, e preciso de uma ajuda de vocês.
Gostaria de fazer uma Macro que Localizasse na Plan1, na Coluna J a palavra "Sim" e movesse todas a linhas deste critério para a Plan2 de forma que não ficasse "furos" entre as linhas da Plan1.
Gostaria também, que ao mover a linha para a Plan2, que adicionasse na Coluna K a Data atual (Date) e na Coluna L a palavra "Não".

Deixo o arquivo em anexo.
Agradeço desde já!
Abraços.

[Vidal]

Serve com fórmulas?! Eu ainda não domino VBA, então.. fiz com fórmulas. Se isso ajudar vc, ou se puder ajudar alguém a ter uma luz e criar uma versão disto em VBA pra ti eu fico feliz tbm! Abç
A Planilha que fiz contém apenas as fórmulas (sem as suas macros), então vc precisa assimilar a idéia do que fiz e reproduzir em sua própria planilha que contém suas macros.. quando eu abri no Libreoffice ele removeu suas macros... por isso estou te enviando somente com as fórmulas que eu criei, ok?! Assimile e reproduza a idéia em sua planilha.

[alexandrevba]

Bom dia!!

Seria algo próximo disso?

Código: Selecionar todos

Sub AleVBA_573()
Dim wsDest As Worksheet, wsOrg As Worksheet

Set wsOrg = ThisWorkbook.Worksheets("Patio")
Set wsDest = ThisWorkbook.Worksheets("Expedidas")

    wsDest.Range("A6:K5000").ClearContents
    With wsOrg.Range("A6").CurrentRegion
        .AutoFilter field:=10, Criteria1:="Sim"
        .Columns("A:J").SpecialCells(xlCellTypeVisible).Copy Destination:=wsDest.Range("A7")
        .AutoFilter
    End With
    
    wsDest.Rows(6).EntireRow.Delete
'Obs: Você não especificou se vai querer os dados de forma que serão sucesivamente um em baixo do outro (Como BD)
End Sub

Att

[SoNiCCrAzY]

Alexandre, o codigo está copiando, porém está removendo os Filtros da linha 6, e não está apagando as linhas do Critério "Sim" da Plan1.



Sm, preciso que os dados sejam inseridos sucessivamente um embaixo do outro (como Banco de Dados).
Também que seja preenchido a Coluna K (Com a data Atual) e Coluna L(Com a palavra "Não") da Plan2 ao "expedir".

A ideia é, na Plan1 ter controle de tudo que está na area de Pré-Expedição, que ao preencher a Coluna J como "Sim", a macro(botão "Expedir") buscar e mover(sem deixar "furos" entre as linhas da Plan1) para Plan2 onde terei o controle de tudo que já saiu. Ficando na Plan1 oque ainda vai sair.

Poderia me ajudar?

Vidal, vou dar uma olhada, obrigado!
Obrigado galera pela atenção.

[alexandrevba]

Boa tarde!!

Veja se ajuda.

Código: Selecionar todos

Sub AleVBA_573V2()
Dim wsDest As Worksheet, wsOrg As Worksheet
Dim Lr As Long

Set wsOrg = ThisWorkbook.Worksheets("Patio")
Set wsDest = ThisWorkbook.Worksheets("Expedidas")
Application.ScreenUpdating = 0
    'wsDest.Range("A7:K5000").ClearContents
    With wsOrg.Range("A6").CurrentRegion
        Lr = wsDest.Cells(Rows.Count, "J").End(xlUp).Row
        .AutoFilter field:=10, Criteria1:="Sim" 'Pega o valor da coluna J na guia Patio
        .Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy Destination:=wsDest.Cells(.Rows.Count, "A").End(xlUp).Offset(1)
        .AutoFilter
    End With
    
    Lr2 = wsDest.Cells(Rows.Count, "J").End(xlUp).Row
    wsDest.Range("K7").Value = Date
    wsDest.Range("L7").Value = "Não"
    Range("K7:L7").AutoFill Destination:=Range("K7:L" & Lr2), Type:=xlFillDefault
Application.ScreenUpdating = 1
End Sub

[SoNiCCrAzY]

Boa tarde.
Alexandre, estou quase lá!
Então, o código não está removendo as linhas da Plan1, e está removendo os Filtros.
Outro detalhe, preciso na Plan2 que seja preenchido com a Data e Não (Coluna K,L) em todas as linhas "Expedidas". (A parte de inserir as bordas eu faço por aqui, rs...)

Agradeço novamente pela ajuda! Segue imagem:

[alexandrevba]

Boa tarde!!

e está removendo os Filtros.

Eu não entendi...

Quanto aos dados no meu teste eu não tive problema.

Att

[SoNiCCrAzY]

Alexandre.
O codigo está removendo os Filtros da Linha 06 da Plan1.
Não está removendo as linhas copiadas da Plan1, preciso que sejam removidas. (Remover todas com Coluna J= "Sim")
Gostaria também que ao copiar para Plan2, as colunas K e L(Data e "Não") deve ser inserida em todas as linhas copias.

Estou quebrando a cabeça aqui pra botar isso pra funcionar rsrsrs

Se puder dar uma luz...
Agradeço desde já

[alexandrevba]

Boa tarde!!

Não está removendo as linhas copiadas da Plan1

mas não foi isso que você solicitou no seu 1º post, por isso eu não o fiz.

Código: Selecionar todos

Option Explicit

Sub AleVBA_573V3()
Dim wsDest As Worksheet, wsOrg As Worksheet
Dim Lr As Long

Set wsOrg = ThisWorkbook.Worksheets("Patio")
Set wsDest = ThisWorkbook.Worksheets("Expedidas")
Application.ScreenUpdating = 0
    'wsDest.Range("A7:K5000").ClearContents
    With wsOrg.Range("A6").CurrentRegion
        Lr = wsDest.Cells(Rows.Count, "J").End(xlUp).Row
        .AutoFilter field:=10, Criteria1:="Sim" 'Pega o valor da coluna J na guia Patio
        .Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy Destination:=wsDest.Cells(.Rows.Count, "A").End(xlUp).Offset(1)
        .Offset(1, 0).SpecialCells(xlCellTypeVisible).Delete shift:=xlUp
        .AutoFilter
    
        With wsDest
            Lr2 = .Cells(Rows.Count, "J").End(xlUp).Row
            .Range("K7").Value = Date
            .Range("L7").Value = "Não"
        End With
    End With
    wsDest.Activate
    wsDest.Range("K7:L7").AutoFill Destination:=Range("K7:L" & Lr2), Type:=xlFillDefault
    wsOrg.Select
Application.ScreenUpdating = 1
End Sub

Att

[SoNiCCrAzY]

Alexandre
O codigo agora apresenta o erro: ""O método Autofill da classe Range falhou." ao ser executado.
Na linha:
"wsDest.Range("K7:L7").AutoFill Destination:=Range("K7:L" & Lr2), Type:=xlFillDefault"

[alexandrevba]

Boa tarde!!

Cara, testa com o arquivo modelo, pois eu não tive problema!!

Att

[SoNiCCrAzY]

Alexandre.
Agora funcionou!

Só preciso de umas alterações:
- Ao rodar a macro, está "bagunçando" as datas das linhas de baixo...
- Adicionar sempre na ultima linha em branco da Plan2.
- E se não houver nenhuma linha da Plan1 com a Coluna J = "Sim" gerar uma msgbox "Não há embalagem a ser expedida."
(Pois rodando a macro mesmo sem nenhuma linha do critério "Sim", está adicionando linha em branco na Plan2.)

Só preciso dessas alterações para finalizar!
Obrigado pela força Alexandre.

[alexandrevba]

Boa noite!!

Por favor click na mãozinha!!!!!!!!!!

Use uma condição...

- Adicionar sempre na ultima linha em branco da Plan2.

Isso a linha abaixo já faz

Código: Selecionar todos

.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy Destination:=wsDest.Cells(.Rows.Count, "A").End(xlUp).Offset(1)

E se não houver nenhuma linha da Plan1 com a Coluna J = "Sim" gerar uma msgbox "Não há embalagem a ser expedida."
(Pois rodando a macro mesmo sem nenhuma linha do critério "Sim", está adicionando linha em branco na Plan2.)

Tente essa condição...

Código: Selecionar todos

If wsOrg.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then

[SoNiCCrAzY]

Bom dia, Alexandre.
A condição "If wsOrg.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then" funcionou perfeitamente, Obrigado!

- Adicionar sempre na ultima linha em branco da Plan2.

Realmente, está adicionando na ultima linha.
Porém, alterando todas as Datas (Coluna K) desde a primeira linha até a ultima de forma crescente, e eu preciso que seja inserido a Data apenas das linhas que estão sendo "expedidas" com a macro.
Segue imagem:

E também a caixa de seleção dos Filtros da Plan1, estão sendo removidas.
Como posso arrumar esses "bugs" ?
Segue arquivo em anexo, caso precise.
Agradeço pela atenção.

[alexandrevba]

Boa tarde!!

Tente assim.
Não se esqueça de clickar na mãozinha

Código: Selecionar todos

Sub AleVBA_573V3()
Dim wsDest As Worksheet, wsOrg As Worksheet
Dim Lr, Lr2 As Long

Set wsOrg = ThisWorkbook.Worksheets("Patio")
Set wsDest = ThisWorkbook.Worksheets("Expedidas")
Application.ScreenUpdating = 0
    'wsDest.Range("A7:K5000").ClearContents
    With wsOrg.Range("A6").CurrentRegion
        Lr = wsDest.Cells(Rows.Count, "J").End(xlUp).Row
        .AutoFilter field:=10, Criteria1:="Sim" 'Pega o valor da coluna J na guia Patio
        If wsOrg.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
        .Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy Destination:=wsDest.Cells(.Rows.Count, "A").End(xlUp).Offset(1)
        .Offset(1, 0).SpecialCells(xlCellTypeVisible).Delete shift:=xlUp
        .AutoFilter
        With wsDest
        Lr2 = .Cells(Rows.Count, "J").End(xlUp).Row
            Do While Lr <= Lr2
                .Range("K" & Lr).Value = Date
                .Cells(Lr, "L").Value = "Não"
                Lr = Lr + 1
            Loop
        End With
    wsDest.Activate
    wsDest.Range("K7:L7").AutoFill Destination:=Range("K7:L" & Lr2), Type:=xlFillDefault
    wsOrg.Select
Application.ScreenUpdating = 1
Else
MsgBox "Não há embalagens a serem expedidas."
End If
End With
End Sub

Att