Fórum Excel Bácico, Avançado e Vba

Este fórum é destina a usuário de Excel, que queiram compartilhar informações a básicas, avançadas e programação em VBA...
 
InícioInício  FAQFAQ  BuscarBuscar  MembrosMembros  GruposGrupos  Registrar-seRegistrar-se  Login  

Compartilhe | 
 

 Copiar e colar

Ver o tópico anterior Ver o tópico seguinte Ir em baixo 
AutorMensagem
Marco.Andrade



Mensagens : 2
Data de inscrição : 21/11/2013

MensagemAssunto: Copiar e colar   Qui Nov 21, 2013 1:38 am

Pessoal, boa noite,

Alguem consegue me ajudar a sintetizar o código abaixo?

Meu arquivo tem 01 planilha de origem e 46 de destino, se eu replicar este código 40 e tantas vezes ele ficará muito pesado!

Me ajudem



Sub Copiar e Colar()

Dim wsOrigem2 As Worksheet
Dim wsDestino2 As Worksheet
Dim wsDestino3 As Worksheet

Set wsOrigem2 = Worksheets("Origem2")
Set wsDestino2 = Worksheets("Destino2")
Set wsDestino3 = Worksheets("Destino3")


With wsOrigem2
'Produto 1
.Range("d3:d5").Copy Destination:=wsDestino2.Range("B6")
.Range("e3:e5").Copy Destination:=wsDestino2.Range("e6")
.Range("f3:f5").Copy Destination:=wsDestino2.Range("h6")
.Range("g3:g5").Copy Destination:=wsDestino2.Range("k6")
.Range("h3:h5").Copy Destination:=wsDestino2.Range("n6")
.Range("i3:i5").Copy Destination:=wsDestino2.Range("q6")
.Range("j3:j5").Copy Destination:=wsDestino2.Range("t6")
.Range("k3:k5").Copy Destination:=wsDestino2.Range("w6")
.Range("l3:l5").Copy Destination:=wsDestino2.Range("z6")
.Range("m3:m5").Copy Destination:=wsDestino2.Range("ac6")
.Range("n3:n5").Copy Destination:=wsDestino2.Range("af6")
.Range("o3:o5").Copy Destination:=wsDestino2.Range("ai6")

'Produto 2
.Range("d6:d8").Copy Destination:=wsDestino3.Range("B6")
.Range("e6:e8").Copy Destination:=wsDestino3.Range("e6")
.Range("f6:f8").Copy Destination:=wsDestino3.Range("h6")
.Range("g6:g8").Copy Destination:=wsDestino3.Range("k6")
.Range("h6:h8").Copy Destination:=wsDestino3.Range("n6")
.Range("i6:i8").Copy Destination:=wsDestino3.Range("q6")
.Range("j6:j8").Copy Destination:=wsDestino3.Range("t6")
.Range("k6:k8").Copy Destination:=wsDestino3.Range("w6")
.Range("l6:l8").Copy Destination:=wsDestino3.Range("z6")
.Range("m6:m8").Copy Destination:=wsDestino3.Range("ac6")
.Range("n6:n8").Copy Destination:=wsDestino3.Range("af6")
.Range("o6:o8").Copy Destination:=wsDestino3.Range("ai6")

End With


MsgBox "Introdução de Dados Concluída"



End Sub
Voltar ao Topo Ir em baixo
Ver perfil do usuário
alexandrevba



Mensagens : 1820
Data de inscrição : 13/07/2011
Localização : Serra - ES

MensagemAssunto: Re: Copiar e colar   Qui Nov 21, 2013 1:52 am

Boa noite!!

E o que você quer?..executar a macro varias vezes?? confused 
Eu não entendi muito bem...
Att
Voltar ao Topo Ir em baixo
Ver perfil do usuário
Marco.Andrade



Mensagens : 2
Data de inscrição : 21/11/2013

MensagemAssunto: Re: Copiar e colar   Qui Nov 21, 2013 2:53 am

Olá, me desculpe acho que na pressa deixei de ser claro....
Na verdade passei o código para 02 produtos, mas são 46 produtos, cada um deve ser colado em uma planilha.

Então, se eu manter essa estrutura, deverei inserir no codigo outros 44 produtos o que aumentara inúmeras linhas.

Como observa-se existe alguns padrões no codigo (aumentarão colunas de D a O; intervalos de linhas sequenciais; etc. )

Pensei em aplicar um FOR/NEXT mas "travei".

Grato pela ajuda!
Voltar ao Topo Ir em baixo
Ver perfil do usuário
alexandrevba



Mensagens : 1820
Data de inscrição : 13/07/2011
Localização : Serra - ES

MensagemAssunto: Re: Copiar e colar   Qui Nov 21, 2013 3:39 pm

Bom dia!!

Tente adaptar a ideia abaixo.
Código:
Sub TenteAdaptar()
Application.ScreenUpdating = False

Dim sSheet As String
Dim i As Long
Dim j As Long
Dim wsOrigem2 As Worksheet
Dim wsDestino As Worksheet

Set wsOrigem2 = Sheets("Origem2")
For i = 1 To 40
    sSheet = "Destino" & i + 1
    Set wsDestino = Sheets(sSheet)
   
    With wsOrigem2
        For j = 1 To 12
            .Cells(i * 3, j + 3).Resize(3, 1).Copy wsDest.Cells(6, (j * 3) - 1)
        Next j
    End With
Next i
   
Application.ScreenUpdating = True
End Sub
Att
Voltar ao Topo Ir em baixo
Ver perfil do usuário
Conteúdo patrocinado




MensagemAssunto: Re: Copiar e colar   Hoje à(s) 8:22 pm

Voltar ao Topo Ir em baixo
 
Copiar e colar
Ver o tópico anterior Ver o tópico seguinte Voltar ao Topo 
Página 1 de 1
 Tópicos similares
-
» Cópia de links ao copiar e colar
» Creditos ao copiar e colar
» Gif com opção copiar/colar
» colar de protecçao polisport e cinta!
» Copiar backup

Permissão deste fórum:Você não pode responder aos tópicos neste fórum
Fórum Excel Bácico, Avançado e Vba :: Avançado/VBA :: Excel Avançado/VBA-
Ir para: