Overfør data fra et regneark til et andet via makro

Er det 2 ark i samme Excel fil?
Og så velkommen til Eksperten

Mange tak :)

Og nej det er to forskellige Excel filer

Rem VBA koden anbringes under Ark1 I filen Produkt
Rem HøjreKlik på ProduktId i A2 for at udføre "dataoverførelsen"
Rem Hvis ønskeligt kan du få filerne. @-adresse under min profil


Dim produkt As Object

Const dataSamlerSti = "C:\Users\peter\Desktop\Eksp_IT-rookie_080715\"              '<---- tilpasses
Const dataSamlerFilNavn = "Datasamler.xlsx"                                        '<---- - " -
Dim dataSamler As Object
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim produktId, rækDs As Integer
    Set produkt = ActiveWorkbook
   
    If Target.Address = "$A$2" Then
        Cancel = True
       
        produktId = Target
       
        Set dataSamler = CreateObject("Excel.Application")
        dataSamler.Workbooks.Open dataSamlerSti & dataSamlerFilNavn
       
        rækDs = findRækkeDataSamler(produktId)
        If rækDs > 0 Then
            kopierData rækDs
            dataSamler.ActiveWorkbook.Save
        Else
            MsgBox "ProduktId ikke fundet"
        End If
    End If
    dataSamler.Quit
    Set dataSamler = Nothing
End Sub
Private Function findRækkeDataSamler(produktId)
Dim antalRækker As Integer
    antalRækker = dataSamler.ActiveCell.SpecialCells(xlLastCell).Row
   
    With dataSamler.Sheets(1)
        dataSamler.Sheets(1).Activate
       
        For Each cc In .Range("A2:A" & antalRækker)
            If produktId = cc Then
                findRækkeDataSamler = cc.Row
                Exit Function
            End If
        Next cc
    End With
    findRækkeDataSamler = 0
End Function
Private Sub kopierData(rækDs)
    With dataSamler.Sheets(1)
        .Range("B" & rækDs) = produkt.Sheets(1).Range("E5")
        .Range("C" & rækDs) = produkt.Sheets(1).Range("E7")
        .Range("D" & rækDs) = produkt.Sheets(1).Range("E9")
        .Range("E" & rækDs) = produkt.Sheets(1).Range("E11")
        .Range("F" & rækDs) = produkt.Sheets(1).Range("E13")
        .Range("G" & rækDs) = produkt.Sheets(1).Range("E15")
    End With
End Sub

Super tak for hjælpen :) har sendt mail til dig

Selv tak.