Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Macro pesada - memo...
 
Notifications
Clear all

Macro pesada - memoria cheia

 
2024 - VBA & Macros
Post Recente por teleguiado 6 anos atrás
9 Posts
4 Usuários
0 Reactions
1,803 Visualizações
RSS
 barison28
(@barison28)
Posts: 56
Trusted Member
Topic starter
 

Bom dia,

ru tenho essa macro mas é muito extença, é uma macro para cada linha eu tentei fazer desse jeito mas não consegui da mensagem de erro, não consigo enviar a planilha pois é 6mb.

Option Explicit

Sub CopiaColaValores()
  
    Dim UltimaLinha As Long
    Dim RngACopiar As Range
    
    'Define o Range a ser Copiado
    Set RngACopiar = Worksheets("TCH HORA").Range("E9")
    
    
    
    'Copia
    RngACopiar.Copy
    
    'Verifica a ultima linha preenchida na Coluna 3(C) da Plan2(Destino)
    UltimaLinha = Worksheets("QUADRO EVOLUTIVO").Cells(Rows.Count, 3).End(xlUp).Row
    
    'Se for menor que 11 - ou seja se C11 estiver Vazia
    If UltimaLinha < 1 Then
        UltimaLinha = 1
        
        
    Else

        UltimaLinha = UltimaLinha + 1
        Worksheets("QUADRO EVOLUTIVO").Range("D" & UltimaLinha).PasteSpecial Paste:=xlPasteValues
        
    End If
    
    Worksheets("QUADRO EVOLUTIVO").Range("D" & UltimaLinha).PasteSpecial Paste:=xlPasteValues
    
    Set RngACopiar = Worksheets("TCH HORA").Range("P4")
           
            'Copia
    RngACopiar.Copy
    Worksheets("QUADRO EVOLUTIVO").Ranges("C", "E", "F", "G", "H", "L", "M", "N", "O", "P", "Q", "U", "V", "W", "X", "Y", "Z", "I", "R", "AA" & UltimaLinha).PasteSpecial Paste:=xlPasteValues
    
    
    
    Set RngACopiar = Worksheets("TCH HORA").Range("H3", "L6", "L4", "P8", "Q4", "E17", "H11", "L14", "L12", "Q8", "R4", "E25", "H19", "L22", "L20", "R8", "P10", "Q10", "R10")
 
           
    
    Application.CutCopyMode = False
    
    End Sub
 
Postado : 16/07/2018 2:48 am
 MPrudencio
(@mprudencio)
Posts: 2749
Famed Member
 

Não precisa postar a planilha inteira apenas uma parte dela com alguns dados.

O importante é que o layout seja identico.

Marcelo Prudencio
Microsoft Excel Brasil no Facebook

"Começar já é a metade do caminho."
Autor Desconhecido

Simplifica que simples fica.
Nicole Tomazella.

"O Simples é Sempre Melhor Que o Complicado"
Jorge Paulo Lemann.

 
Postado : 16/07/2018 10:36 am
 barison28
(@barison28)
Posts: 56
Trusted Member
Topic starter
 

klarc28

não consegui amigo aplicar.

 
Postado : 16/07/2018 3:15 pm
 teleguiado
(@teleguiado)
Posts: 142
Estimable Member
 

Tente assim.

Worksheets("QUADRO EVOLUTIVO").Range("C" & UltimaLinha, "E" & UltimaLinha, "F" & UltimaLinha, "G" & UltimaLinha, "H"& UltimaLinha, "L" & UltimaLinha, "M" & UltimaLinha, "N" & UltimaLinha, "O" & UltimaLinha, "P" & UltimaLinha, "Q" & UltimaLinha, "U" & UltimaLinha, "V" & UltimaLinha, "W" & UltimaLinha, "X" & UltimaLinha, "Y" & UltimaLinha, "Z" & UltimaLinha, "I" & UltimaLinha, "R" & UltimaLinha, "AA" & UltimaLinha).PasteSpecial Paste:=xlPasteValues

Obrigado.

Teleguiado.
E-mail: telegui4do@gmail.com

 
Postado : 16/07/2018 4:02 pm
 barison28
(@barison28)
Posts: 56
Trusted Member
Topic starter
 

teleguiado

eu não estou conseguindo, nao tenho muita experiencia em vba. pode me dizer onde substituo?

Editado por Patropi: Use o botão Responder que fica logo abaixo da janela de Resposta, não use citação sem necessidade.

 
Postado : 16/07/2018 4:25 pm
 teleguiado
(@teleguiado)
Posts: 142
Estimable Member
 

Substitua essa parte:

Worksheets("QUADRO EVOLUTIVO").Range("C", "E", "F", "G", "H", "L", "M", "N", "O", "P", "Q", "U", "V", "W", "X", "Y", "Z", "I", "R", "AA" & UltimaLinha).PasteSpecial Paste:=xlPasteValues

Por esta:

Worksheets("QUADRO EVOLUTIVO").Range("C" & UltimaLinha, "E" & UltimaLinha, "F" & UltimaLinha, "G" & UltimaLinha, "H"& UltimaLinha, "L" & UltimaLinha, "M" & UltimaLinha, "N" & UltimaLinha, "O" & UltimaLinha, "P" & UltimaLinha, "Q" & UltimaLinha, "U" & UltimaLinha, "V" & UltimaLinha, "W" & UltimaLinha, "X" & UltimaLinha, "Y" & UltimaLinha, "Z" & UltimaLinha, "I" & UltimaLinha, "R" & UltimaLinha, "AA" & UltimaLinha).PasteSpecial Paste:=xlPasteValues

Obrigado.

Teleguiado.
E-mail: telegui4do@gmail.com

 
Postado : 16/07/2018 7:21 pm
 barison28
(@barison28)
Posts: 56
Trusted Member
Topic starter
 

não consegui ainda, dá essa msg de erro.

 
Postado : 16/07/2018 10:01 pm
 klarc28
(@klarc28)
Posts: 971
Prominent Member
 
Worksheets("QUADRO EVOLUTIVO").Range("C" & UltimaLinha, "E" & UltimaLinha, "F" & UltimaLinha, "G" & UltimaLinha, "H"& UltimaLinha, "L" & UltimaLinha, "M" & UltimaLinha, "N" & UltimaLinha, "O" & UltimaLinha, "P" & UltimaLinha, "Q" & UltimaLinha, "U" & UltimaLinha, "V" & UltimaLinha, "W" & UltimaLinha, "X" & UltimaLinha, "Y" & UltimaLinha, "Z" & UltimaLinha, "I" & UltimaLinha, "R" & UltimaLinha, "A" & UltimaLinha).PasteSpecial Paste:=xlPasteValues
 
Postado : 17/07/2018 4:16 am
 teleguiado
(@teleguiado)
Posts: 142
Estimable Member
 

klarc nem tinha visto que ele tinha colocado ranges. :lol: heheh
Ja editei o que tinha postado.
A ultima coluna é "AA". ;)

Obrigado.

Teleguiado.
E-mail: telegui4do@gmail.com

 
Postado : 17/07/2018 6:52 am
Forum Jump:
  Tópico Anterior
Próximo Tópico