Gem kopi af enkelte data i andet ark.

hvis der altid er værdier i D kolonnen i Sheet"input M1" , kan denne bruges

Public Sub Kopier()
Dim Til As Object, Fra As Object, FraCelle As Variant, TilCelle As Variant, RW As Long, I As Integer
Set Fra = Sheets("M1 beregn")
Set Til = Sheets("input M1")
  fracells = Array("E11", "E20", "E34", "G20", "G34", "I20", "I34")
  TilCells = Array("D", "E", "F", "G", "H", "I", "J")
  RW = Til.Range("D65536").End(xlUp).Row + 1
  If RW < 4 Then RW = 4
  For I = 0 To UBound(fracells)
  Til.Range(TilCells(I) & RW) = Fra.Range(fracells(I))
  Next

End Sub

der var lige et par stavefejl

Public Sub Kopier()
    Dim Til As Object, Fra As Object, FraCells As Variant, TilCelles As Variant, RW As Long, I As Integer
    Set Fra = Sheets("M1 beregn")
    Set Til = Sheets("input M1")
    FraCells = Array("E11", "E20", "E34", "G20", "G34", "I20", "I34")
    TilCells = Array("D", "E", "F", "G", "H", "I", "J")
    RW = Til.Range("D65536").End(xlUp).Row + 1
    If RW < 4 Then RW = 4
    For I = 0 To UBound(FraCells)
        Til.Range(TilCells(I) & RW) = Fra.Range(FraCells(I))
    Next

End Sub

Det virker meget fint (vælger dog at bruge; Private Sub CommandButton1_Click()) i stedet for Puplic Sub kopier ;-)

Et lille ekstra spørgsmål.. Kan man gøre sådan at Man ikke kan skrive det samme i D kolonnen, evt. med en promt af at data for kolonnen allerede eksistere?
(grunden er at de enkelte data i kolonne D er unikke, hvilket der ikke bliver taget højde for nu..)

og hvis du så lige hurtigt forklarer hvordan jeg giver dig dine velfortjente points (det er det første spørgsmål, jeg har oprette ;-))
/ Istebjerg

Public Sub Kopier()
    Dim Til As Object, Fra As Object, FraCells As Variant, TilCelles As Variant, RW As Long, I As Integer
    Dim Tjek As Variant, OK As Boolean
    OK = True
    Set Fra = Sheets("M1 beregn")
    Set Til = Sheets("input M1")
    FraCells = Array("E11", "E20", "E34", "G20", "G34", "I20", "I34")
    TilCells = Array("D", "E", "F", "G", "H", "I", "J")
    RW = Til.Range("D65536").End(xlUp).Row + 1
    If RW < 4 Then RW = 4

    Tjek = Til.Range("D4:D" & RW - 1)
    For x = 1 To UBound(Tjek)
        If Tjek(x, 1) = Fra.Range("E11") Then
            OK = False
            Exit For
        End If
    Next

    If OK Then
        For I = 0 To UBound(FraCells)
            Til.Range(TilCells(I) & RW) = Fra.Range(FraCells(I))
        Next
    Else
        MsgBox " nummeret er brugt, tast om"
    End If
End Sub

Jeg skal først svare,
så markerer du mit navn og trykker accepter.

;-)) og velkommen

Du er for sej... er det noget med at du skal smide et svar? 100 points til dig og tusind tak for hjælpen...

tak for point ;-))

Øhhh... Kunne ikke lige få det sidste til at virke??

Mulig fejl i linien : For x = 1 To UBound(Tjek)??

Håber stadig du er på kabbak..

Det er fordi der ikke er data i endnu
ret denne linie

Tjek = Til.Range("D4:D" & RW - 1)
nu lader vi den starte 2 rækker højere oppe, der har du vel overskrifter eller tomme

Tjek = Til.Range("D2:D" & RW - 1)

Perfekt !!! Tak igen..