Otimizar VBA

2024 - VBA & Macros

Post Recente por TJ10 8 anos atrás

5 Posts

2 Usuários

0 Reactions

1,292 Visualizações

RSS

TJ10

(@tj10)

Posts: 9

Active Member

Topic starter

Bom dia Galerinha,

Alguem poderia me ajudar, criei sua Macros, porem elas rodam lentamente, teria alguma forma de deixar elas mais simplificas, com menos linhas, como não entendo muito criei do jeito que sei:

A Sub Gravar copia os dados da coluna B e coluna F para a coluna K. Já a Sub Inserir_Inventario copia a coluna K e a coluna M para a aba Pasta de Transferencia na coluna A e B.

Sub gravar()

Dim linha, coluna, linhak, colunak

linha = 2
coluna = 2
linhak = 2
colunak = 11

Do While Cells(linha, coluna) <> ""
    Cells(linha, coluna).Select
    Selection.Copy
        Do While Cells(linhak, colunak) <> ""
        linhak = linhak + 1
        Loop
    Cells(linhak, colunak).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
linha = linha + 1
Loop

linha = 2
linhak = 2
coluna = 6

Do While Cells(linha, coluna) <> ""
 Cells(linha, coluna).Select
    Selection.Copy
        Do While Cells(linhak, colunak) <> ""
        linhak = linhak + 1
        Loop
    Cells(linhak, colunak).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
linha = linha + 1
Loop

'remover duplicados da coluna K'
Columns("K:K").Select
    ActiveSheet.Range("K:k").RemoveDuplicates Columns:=1, Header:=xlNo

'mensagem de aviso se foi ou não copiados'
If linha = 2 Then
MsgBox "Não existe produto contado", vbInformation, "Inventário Kennedy"
Else
Application.CutCopyMode = False
MsgBox "Arquivos copiados com Sucesso", vbInformation, "Inventario Kennedy"
End If

End Sub
Sub Inserir_Inventario()
'
Dim linha, coluna, linhap, colunap


If MsgBox("Deseja Inserir o inventário?", vbYesNo, "Inventário Kennedy") = vbYes Then
   linha = 2
   coluna = 11
   coluna2 = 13
   linhap = 1
   colunap = 1
   colunap2 = 2

   
    Do While Sheets("inventario").Cells(linha, coluna) <> ""
        Sheets("inventario").Select
        Cells(linha, coluna).Select
        Selection.Copy
            Do While Sheets("Pasta de Transferencia").Cells(linhap, colunap) <> ""
             linhap = linhap + 1
            Loop
        Sheets("Pasta de Transferencia").Select
        Cells(linhap, colunap).Select
        ActiveSheet.Paste
        linha = linha + 1
    Loop
 
 linha = 2
 linhap = 1
 colunap = 2

   Do While Sheets("inventario").Cells(linha, coluna2) <> ""
        Sheets("inventario").Select
        Cells(linha, coluna2).Select
        Selection.Copy
            Do While Sheets("Pasta de Transferencia").Cells(linhap, colunap) <> ""
             linhap = linhap + 1
            Loop
        Sheets("Pasta de Transferencia").Select
        Cells(linhap, colunap).Select
       ' ActiveSheet.Paste
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
        linha = linha + 1
    Loop
   
    Exit Sub
Else
MsgBox ("Operação Cancelada.")
    Exit Sub
End If

Application.CutCopyMode = False
    
End Sub

Postado : 29/05/2017 8:41 am

brunoxro

(@brunoxro)

Posts: 698

Honorable Member

Boa tarde TJ,

Você ao invés de copiar linha por linha, pode selecionar e copiar a área que precisa diretamente.

Veja o código que coloquei no arquivo em anexo.

att,

Postado : 29/05/2017 1:33 pm

TJ10

(@tj10)

Posts: 9

Active Member

Topic starter

Boa tarde Bruno,

Ficou 1000 vezes mais rápido, porem não esta bem da forma que eu precisava, precisava que copiasse tanto a coluna B como a coluna F para a Coluna K, póis a coluna B trata-se da 1ª contagem e a coluna F da 2ª, queria que ambas as colunas fosses para a coluna K e depois que inseridos na K que removesse os códigos duplicados da coluna K.

Postado : 29/05/2017 1:57 pm

brunoxro

(@brunoxro)

Posts: 698

Honorable Member

Boa tarde,

Basta colocar o trecho para copiar os dados da coluna F.

Veja:

Sub gravar()

    ThisWorkbook.Activate
    
    Dim w           As Double
    Dim Nlin        As Double
    Dim Ulin        As Double
    
    'Número de linhas a ser copiadas
    Nlin = Range("B1048575").End(xlUp).Row
    
    'Linha Vazia da coluna K
    w = Range("K1048575").End(xlUp).Offset(1, 0).Row
    
    'Coluna B para a K
    Range("B2:B" & Nlin).Copy Range("K" & w)
        
    'Número de linhas a ser copiadas
    Nlin = Range("F1048575").End(xlUp).Row
    
    'Linha Vazia da coluna K
    w = Range("K1048575").End(xlUp).Offset(1, 0).Row
    
    'Coluna F para a K
    Range("F2:F" & Nlin).Copy Range("K" & w)

    Application.CutCopyMode = False
    
    'Remove duplicados da coluna K'
    ActiveSheet.Range("K:K").RemoveDuplicates Columns:=1, Header:=xlNo
 
End Sub

*O resultado do exemplo vai ser o mesmo, porque no final na coluna K os dados duplicados são removidos.

Postado : 29/05/2017 3:02 pm