Copiar e colar

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

Boa noite!!

E o que você quer?..executar a macro varias vezes??  
Eu não entendi muito bem...
Att

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!

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