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,808 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: [email protected]

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: [email protected]

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