Indsæt række i et interval

Mener du således:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column = 6 or Target.Column = 1 Then
Range("A" & Target.Row & ":E" & Target.Row).Insert Shift:=xlDown
Else
Range("F" & Target.Row & ":J" & Target.Row).Insert Shift:=xlDown
End If
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column = 1 Then Range("A" & Target.Row & ":E" & Target.Row).Insert Shift:=xlDown
If Target.Column = 6 Then Range("F" & Target.Row & ":J" & Target.Row).Insert Shift:=xlDown
End Sub

ja indbyggede funktioner udført i vba virker blandt andre ikke i en delt projektmappe.
Så må vi finde en omvej, men jeg når det ikke i dag

nå ok måske ilemming har bedre tid :-)

-> excelent din kode virker helt efter hensigten - såænge at arket ikke er delt. Kan du / i klare den også, så er det helt perfekt. :O))

-> ilemming - jeg har ikke nået at teste din rutine, men gør det senere idag.

Prøv denne :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
lastRow = Range("A1").SpecialCells(xlLastCell).Row
If Target.Column = 1 Then
Range("A" & Target.Row & ":E" & lastRow).Cut Range("A" & Target.Row + 1)
End If
If Target.Column = 6 Then
Range("F" & Target.Row & ":J" & lastRow).Cut Range("F" & Target.Row + 1)
End If
End Sub

Den virker nu når arket er delt men der opstår en konflikt med en anden kode, som jeg har fundet her sitet.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("H3:H90, P3:P90")) Is Nothing Then Exit Sub
If Target.Interior.ColorIndex = xlNone Then
Target.Interior.ColorIndex = 9
Else
Target.Interior.ColorIndex = xlNone
End If


End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
LastRow = Range("A1").SpecialCells(xlLastCell).Row
If Target.Column = 2 Then
Range("B" & Target.Row & ":H" & LastRow).Cut Range("B" & Target.Row + 1)
End If
If Target.Column = 10 Then
Range("J" & Target.Row & ":P" & LastRow).Cut Range("J" & Target.Row + 1)
End If
End Sub

Hvis jeg klikker på enten kolonne B,  så farves henholdsvis kolonne B til H fra markøren og nedad resten af arket. Tilsvarende hvis det er kolonne J, der aktiveres. Jeg håber at der er en løsning.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.EnableEvents = False
lastRow = Range("A1").SpecialCells(xlLastCell).Row
If Target.Column = 1 Then
Range("A" & Target.Row & ":E" & lastRow).Cut Range("A" & Target.Row + 1)
End If
If Target.Column = 6 Then
Range("F" & Target.Row & ":J" & lastRow).Cut Range("F" & Target.Row + 1)
End If
Application.EnableEvents = True
End Sub

udskift med denne

Det ser rigtigt godt ud, nu virker det, med begge rutiner :O)
En sidste detalje - når der indsættes nogle celler:

Range("A" & Target.Row & ":E" & lastRow).Cut Range("A" & Target.Row + 1)

kan man så bevare rammerne omkring cellerne?

Hvis ikke, så læg et svar, så vil der være point på vej.

Det ser nu ud til rammer kopieres med- well dem jeg har :-)

hvilke rammer har du ?

Det er bare kanterne omkring cellerne

De hedder vis kontur- sat under formater celler.

vist - selvfølgelig

altså en ramme omkring hver celle, eller en ramme omkring hele området ?

ramme omkring hver enkelt celle

åhh mener du at den tomme linie der laves, skal have en ramme også ?

jeps

prøv udskift med denne

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.EnableEvents = False
lastRow = Range("A1").SpecialCells(xlLastCell).Row
If Target.Column = 1 Then
Range("A" & Target.Row & ":E" & lastRow).Cut Range("A" & Target.Row + 1)
End If
If Target.Column = 6 Then
Range("F" & Target.Row & ":J" & lastRow).Cut Range("F" & Target.Row + 1)
End If
ActiveCell.Offset(1, 0).Copy
ActiveCell.Resize(1, 5).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
ActiveCell.Offset(1, 0).Select
Application.EnableEvents = True
End Sub

Så kom der streger på :O), blot er de lodrette streger tykkere end de vandrette streger. Det er den tynde streg, som jeg skal bruge.

prøv lige ændre denne linie til 1,1 i stedet for 1,0
ActiveCell.Offset(1, 0).Copy

ActiveCell.Offset(1, 0).Copy tager en kopi af cellen under den aktive og paster formatet

ActiveCell.Offset(1, 1).Copy tager en kopi af cellen under og en kolonne til højre for den aktive og paster formatet

så det undrer mig noget at formatet ikke er ens !!!

Den er på plads nu. Jeg ændrede blot:
ActiveCell.Offset(1, 0).Copy  til ActiveCell.Offset(1, 1).Copy,
således at den celle der kopieres fra har en ramme med tynde streger omkring.

Alt er derfor i skønneste orden - så jeg vi gerne sige tak for hjælpen. ;O)).

Læg venligst et svar!

ok velbekom

Kan man bruge dobleclick på begge musetaster? og i givet fald, hvordan skelner man mellem højre og venstre tast?

Nej dobbeltklik virker kun på venstre knap

Har du så et forslag til hvad man kan gøre, hvis jeg vil have en mulighed for at slette en linie i et delt ark? altså modstykket til at indsætte en linie som ovenfor.

Hvis du dobbeltklikker på en tom celle, så flyttes op ellers ned
(obs. koden sletter eller indsætter ikke rækker, men flyter data)

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
Application.EnableEvents = False
If Target.Value = "" Then x = 0: y = 1
If Target.Value <> "" Then x = 1: y = 0
lastRow = Range("A1").SpecialCells(xlLastCell).Row
If Target.Column = 1 Then
Range("A" & Target.Row + y & ":E" & lastRow).Cut Range("A" & Target.Row + x)
End If
If Target.Column = 6 Then
Range("F" & Target.Row + y & ":J" & lastRow).Cut Range("F" & Target.Row + x)
End If
ActiveCell.Offset(1, 0).Copy
ActiveCell.Resize(1, 5).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
ActiveCell.Offset(1, 0).Select
Application.EnableEvents = True
End Sub

Det er da en genial løsning - tak for den. Opretter lige et nyt spørgsmål med nogle point - som tak for hjælpen. ;O)) God weekend.