Excel Como melhorar essa macro

[Caio Rodrigues Almeida]

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!

[Midori]

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.

 

 

[Caio Rodrigues Almeida]

@olliver.soul Muito obrigado, vou tentar aplicar, acredito que essa sequência de loops que eu criei que faz travar, o código ficou muito pesado!

[Eder Neumann]

nos mantenha atualizados por favor.

[Caio Rodrigues Almeida]

@Eder Neumann Pode deixar, hora que eu tiver um tempinho aqui no trabalho vou editar essa macro

[Caio Rodrigues Almeida]

@olliver.soul Cara, não sei porque, mas não consegui aplicar, não deu erro, mas não funcionou, você chegou testar na planilha mesmo?

[Midori]

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"))

 

[Caio Rodrigues Almeida]

@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!

[Caio Rodrigues Almeida]

@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.

[Midori]

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

 

Tipo isso,

 

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

 

[Caio Rodrigues Almeida]

@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.

[CasaDoHardware]

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