Flyt til andet ark med vba

Prøv med denne makro:

Sub FlytTilArk3()
x = ActiveCell.Row
Range(Cells(x, 1), Cells(x, 5)).Copy
Worksheets("Ark3").Select
y = Range("A65535").End(xlUp).Row
Range(Cells(y + 1, 1), Cells(y + 1, 5)).PasteSpecial
Worksheets("Ark1").Select
Application.CutCopyMode = False
End Sub

Sæt denne i ark1 modulet.
den virker ved højreklik

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column < 5 Then
If MsgBox("Kopier rækken", vbYesNo) = vbYes Then
  RW = Worksheets("Ark3").Range("A65536").End(xlUp).Row + 1
  rk = Target.Row
  Range("A" & rk & ":E" & rk).Copy Sheets("Ark3").Range("A" & RW)
  ' Range("A" & rk & ":E" & rk).Delete  ' hvis rækken skal slettes i ark1, så fjern '
Cancel = True
End If
End If
End Sub

koden virker på kolonne 1 til 5, denne er lige rettet til

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column < 6 Then
If MsgBox("Kopier rækken", vbYesNo) = vbYes Then
  RW = Worksheets("Ark3").Range("A65536").End(xlUp).Row + 1
  rk = Target.Row
  Range("A" & rk & ":E" & rk).Copy Sheets("Ark3").Range("A" & RW)
  ' Range("A" & rk & ":E" & rk).Delete  ' hvis rækken skal slettes i ark1, så fjern '
Cancel = True
End If
End If
End Sub

Hej

Jens48
Dit foreslag virker faktisk som jeg ønskede

Kabbak

Dit virkede også dog kan jeg ikke få den til at slette rækken
Jeg har fjernet (´)

Kan det skrives ind i den kode Jens har lavet sådan at den sletter rækken på ark 1

kan det laves sådan at den sletter samme række på ark 2 det er magen til men laver nogle andre udregninger

den sletter ikke hele rækken, men rykker cellerne op i kolonne A til E

Okay det lykkes ikke for mig.

jeg fik bare en fejl.

Run-time error´1004´:
Metoden Delete for klassen Range mislykkes.

jeg får ikke fejl

prøv igen

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column < 6 Then
If MsgBox("Kopier rækken", vbYesNo) = vbYes Then
  RW = Worksheets("Ark3").Range("A65536").End(xlUp).Row + 1
  rk = Target.Row
  Range("A" & rk & ":E" & rk).Copy Sheets("Ark3").Range("A" & RW)
Range("A" & rk & ":E" & rk).Delete Shift:=xlUp ' rækken slettes i ark1
Cancel = True
End If
End If
End Sub

Min makro er nu modificeret, så den nu sletter de 5 celler i ark1 (cellerne nedenfor rykker op)

Sub FlytTilArk3()
x = ActiveCell.Row
Range(Cells(x, 1), Cells(x, 5)).Copy
Worksheets("Ark3").Select
y = Range("A65535").End(xlUp).Row
Range(Cells(y + 1, 1), Cells(y + 1, 5)).PasteSpecial
Worksheets("Ark1").Select
Range(Cells(x, 1), Cells(x, 5)).Delete
Application.CutCopyMode = False
End Sub

Hej Igen.

Jeg kan ikke få det til at virke når der skal slettes rækker. den kommer bare med fejl som da jeg prøvede den fra Kabak.

Hvis du kun vil have makroen til at flytte de første 5 celler, og derefter slette hele rækken, kan du bruge denne makro:

Sub FlytTilArk3()
x = ActiveCell.Row
Range(Cells(x, 1), Cells(x, 5)).Copy
Worksheets("Ark3").Select
y = Range("A65535").End(xlUp).Row
Range(Cells(y + 1, 1), Cells(y + 1, 5)).PasteSpecial
Worksheets("Ark1").Select
Range(Cells(x, 1), Cells(x, 5)).EntireRow.Delete
Application.CutCopyMode = False
End Sub

Hvis makroen skal kopiere hele rækken, før den slettes kan du bruge nedenstående:

Sub FlytTilArk3()
x = ActiveCell.Row
Range(Cells(x, 1), Cells(x, 5)).EntireRow.Copy
Worksheets("Ark3").Select
y = Range("A65535").End(xlUp).Row
Range(Cells(y + 1, 1), Cells(y + 1, 5)).PasteSpecial
Worksheets("Ark1").Select
Range(Cells(x, 1), Cells(x, 5)).EntireRow.Delete
Application.CutCopyMode = False
End Sub

Hej Jens48
Jeg har et hængeparti med dig.

Jeg fik dit forslag til at virke.
send mig lige et svar så du kan få dine point :)
bedre sendt end aldrig ;) ;)

Rart med tilbagemelding

Hej Jens48

Jeg tillader mig lige at stille dig et tillægsspørgsmål. :)
kan man ikke lave koden sådan at den kan flytte over på et låst ark.?
sådan at forstå den låser op inden data flyttes og låser igen ?

Jeg har forsøgt dette men der kommer en fejl fane.


Sub FlytTilArk3()
ActiveSheet.Unprotect
x = ActiveCell.Row
Range(Cells(x, 1), Cells(x, 6)).EntireRow.Copy
Worksheets("Randers").Select
ActiveSheet.Unprotect
y = Range("A65535").End(xlUp).Row
Range(Cells(y + 1, 1), Cells(y + 1, 6)).PasteSpecial
ActiveSheet.Protect
Worksheets("Ark1").Select
Range(Cells(x, 1), Cells(x, 6)).EntireRow.Delete
Application.CutCopyMode = False
ActiveSheet.Protect
End Sub