Ir ao conteúdo
  • Cadastre-se
Caio Rodrigues Almeida

Excel Como melhorar essa macro

Posts recomendados

Olá pessoal!

Preciso da ajuda de quem manja de VBA, fiz uma planilha para solicitar material do estoque, basicamente ela funciona assim: Eu busco um item, coloco a quantidade no campo e aperto um botão de lançar, o que ele faz! Copia e cola numa tabelinha abaixo e cola também em outra aba denominada de "controle", que copia sequencialmente nas duas, usei para isso basicamente esse código:

 

If ActiveCell <> "" Then
        ActiveCell.Offset(1, 0).Select
        End If
    Loop Until ActiveCell = ""
    ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
        :False, Transpose:=False
    Application.CutCopyMode = False

 

Qual é o problema, toda vez que aperto o botão "Lançar", faz td que a macro é para fazer mesmo, cola um abaixo do outro, só que para isso, demora muito, na hora que vai colar, da impressão que a célula percorre a coluna inteira antes de colar.

 

Abaixo segue o código completo da macro e também o link da planilha que eu uso pra quem quiser ver na prática como funciona, gostaria de saber se tem como melhorar esse código pra ser um pouco mais instantâneo copiar e colar.

 

https://drive.google.com/open?id=17yE4788TZbusJZtp1yMdRh6D_afYlJ-G

Sub Lançar()

Range("G4").Select
    Selection.Copy
    Sheets("CONTROLE").Select
    Range("B4").Select
    Do
        If ActiveCell <> "" Then
        ActiveCell.Offset(1, 0).Select
        End If
    Loop Until ActiveCell = ""
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("SOLICITAÇÃO").Select
    Range("B5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("B7").Select
    Do
        If ActiveCell <> "" Then
        ActiveCell.Offset(1, 0).Select
        End If
    Loop Until ActiveCell = ""
    ActiveSheet.Paste
    Sheets("CONTROLE").Select
    Range("C4").Select
    Do
        If ActiveCell <> "" Then
        ActiveCell.Offset(1, 0).Select
        End If
    Loop Until ActiveCell = ""
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("SOLICITAÇÃO").Select
    Range("D5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("D7").Select
    Do
        If ActiveCell <> "" Then
        ActiveCell.Offset(1, 0).Select
        End If
    Loop Until ActiveCell = ""
    ActiveSheet.Paste
    Sheets("CONTROLE").Select
    Range("E4").Select
    Do
        If ActiveCell <> "" Then
        ActiveCell.Offset(1, 0).Select
        End If
    Loop Until ActiveCell = ""
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("SOLICITAÇÃO").Select
    Range("D5").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    Range("B5").Select
    Selection.ClearContents

 

Desde já agradeço!

Compartilhar este post


Link para o post
Compartilhar em outros sites

Está demorando por causa dos loops.

 

Você pode substituir por algo assim,

 

Sub UltimaLinha()
    Dim WksControle    As Worksheet
    Dim UltLinha    As Long
    
    Set WksControle = ThisWorkbook.Worksheets("CONTROLE")
    
    UltLinha = WksControle.Range("B3").End(xlDown).Row + 1
    
    MsgBox UltLinha
End Sub

 

Veja que a macro já identifica a última linha em branco, usando o mesmo recurso do Ctrl+Down a partir de B3.

 

 

  • Curtir 1

Compartilhar este post


Link para o post
Compartilhar em outros sites

Fiz um teste e acho que dessa forma não vai ficar tão prático.

 

Segue outro código com a função Find.

 

Testei na planilha Controle e deu certo, acho que assim fica mais fácil.

 

Sub Lançar()
    Dim WksControle As Worksheet
    Dim Proximo     As Range
    
    Set WksControle = ThisWorkbook.Worksheets("CONTROLE")
    Set Proximo = WksControle.Range("B:B").Find("")
    
        Proximo.PasteSpecial _
            Paste:=xlPasteValues, _
            Operation:=xlNone, SkipBlanks:=False, _
            Transpose:=False
End Sub

No caso da planilha solicitação, é só fazer uma pequena alteração no argumento da função, exemplo

 

    Set Proximo = WksSolicitacao.Range("B:B").Find("", WksSolicitacao.Range("B6"))

 

Compartilhar este post


Link para o post
Compartilhar em outros sites

@olliver.soul vou testar aqui e retorno. Na vdd vou tentar dar uma otimizada, ficou uma macro muito extensa  e pesada, vou tentar aplicar o que você me mandou primeiramente, se continuar pesada vou inventar outra maneira de fazer o que eu quero, tem muito copia e cola, talvez dê para copiar uma quantidade maior de linhas.

 

Muito obrigado pela atenção!

Compartilhar este post


Link para o post
Compartilhar em outros sites

@olliver.soul Fala ae pessoal! Consegui pegar a planilha para atualizar, só estou com uma dúvida, como sou meio leigo, estou com dificuldade para mudar o argumento da função na planilha Solicitação, aparece a msg de erro que o objeto é obrigatório.

Compartilhar este post


Link para o post
Compartilhar em outros sites

@Caio Rodrigues Almeida  Deve estar faltando alguma declaração de variável.

 

Tipo isso,

 

    Dim WksSolicitacao As Worksheet
    
    Set WksSolicitacao = ThisWorkbook.Worksheets("SOLICITAÇÃO")

 

  • Curtir 1

Compartilhar este post


Link para o post
Compartilhar em outros sites

@olliver.soul Muito obrigado novamente, hora que tiver um tempinho vou atualizar, mas só de ter tirado os loops da planilha controle, já melhorou muito a velocidade da macro.

  • Curtir 1

Compartilhar este post


Link para o post
Compartilhar em outros sites

Se eu entendi direito seu problema esse codigo resolve.

 

O codigo abaixo copia as celulas G4, B5 e D5 da planilha "SOLICITAÇÃO" para a primeira linha em branco planilha "CONTROLE"  

 

Sub Lançar()

Dim W As Worksheet
Dim WS As Worksheet
Dim UltimaLinha As Long

Set WS = Sheets("SOLICITAÇÃO")
Set W = Sheets("CONTROLE")
    UltimaLinha = W.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Row

    W.Cells(UltimaLinha, 2).Value = WS.Range("G4").Value
    W.Cells(UltimaLinha, 3).Value = WS.Range("B5").Value
    W.Cells(UltimaLinha, 5).Value = WS.Range("D5").Value
    

WS.Range("B5", "D5").ClearContents

End Sub

 

 

 

 

  • Amei 1

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

×
×
  • Criar novo...

GRÁTIS: minicurso “Como ganhar dinheiro montando computadores”

Gabriel TorresGabriel Torres, fundador e editor executivo do Clube do Hardware, acaba de lançar um minicurso totalmente gratuito: "Como ganhar dinheiro montando computadores".

Você aprenderá sobre o quanto pode ganhar, como cobrar, como lidar com a concorrência, como se tornar um profissional altamente qualificado e muito mais!

Inscreva-se agora!