Fehler beim kopieren der DoubleClick Event

[elamigo]

Hey Leute,

ich nutze aktuell folgendes Makro um per Doppelklick eine Zeile auf ein anderes Tabellenblatt zu kopieren. 

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
With Sheets("Notes")
  Select Case Target.Address(False, False)
 
       Case "B13:C13"
          .Range("B13").Copy
          Sheets("Tabelle1").Range("B9").PasteSpecial (xlPasteAll)

  End Select
End With
Application.CutCopyMode = False
End Sub

Funktioniert soweit super, allerdings wird immer etwas das Format der Tabelle beim Kopieren zerschossen (Rahmenlinien etc.). Um das zu vermeiden habe ich ein Makro welches diese Anpassungen beim aktivieren des Tabllenblattes machen soll.

Code:

Private Sub Worksheet_Activate()

   Range("B9:B36").Select
   Selection.Borders(xlDiagonalDown).LineStyle = xlNone
   Selection.Borders(xlDiagonalUp).LineStyle = xlNone
   Selection.Borders(xlEdgeLeft).LineStyle = xlNone
   Selection.Borders(xlEdgeTop).LineStyle = xlNone
   Selection.Borders(xlEdgeBottom).LineStyle = xlNone
   Selection.Borders(xlEdgeRight).LineStyle = xlNone
   Selection.Borders(xlInsideVertical).LineStyle = xlNone
   Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
   Range("B9:B36").Select
   Selection.Borders(xlDiagonalDown).LineStyle = xlNone
   Selection.Borders(xlDiagonalUp).LineStyle = xlNone
   With Selection.Borders(xlEdgeLeft)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .TintAndShade = 0
       .Weight = xlThin
   End With
   With Selection.Borders(xlEdgeTop)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .TintAndShade = 0
       .Weight = xlThin
   End With
   With Selection.Borders(xlEdgeBottom)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .TintAndShade = 0
       .Weight = xlThin
   End With
   With Selection.Borders(xlEdgeRight)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .TintAndShade = 0
       .Weight = xlThin
   End With
   Selection.Borders(xlInsideVertical).LineStyle = xlNone
   Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
   
   
       Range("B9:B36").Select
   With Selection.Interior
       .PatternColorIndex = xlAutomatic
       .ThemeColor = xlThemeColorDark1
       .TintAndShade = 0
       .PatternTintAndShade = 0
   End With
   
   
End Sub

Allerdings kommt dann im folgende Fehler Meldung und der Debugger zeigt folgendes:

[Elex]

Hi

verwende im ersten Code.

Code:

Case "B13:C13"
Sheets("Tabelle1").Range("B9").Value = Range("B13").Value

Dann sollten keine Formate verändert werden und der zweite Code entfallen.

Gruß Elex

[elamigo]

sehr gute Idee, allerdings passiert bei mir leider nichts. :( Ne Idee? 

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
With Sheets("Notes")
  Select Case Target.Address(False, False)
 
       Case "B13:C13"
           Sheets("Notes Sighting-Round").Range("B9").Value = Range("B13").Value
           
   End Select
End With
Application.CutCopyMode = False
End Sub

Sieht jetzt so aus. Eigentlich nur andere Tabellenblattnamen.

[00202]

Hallo, :19:

wenn du mit dem "Doppelklick-Ereignis" zwei Zellen überwachen möchtest, dann solltest du es so schreiben: :21:

Code:

Case "B13", "C13"
    Cancel = True

Das "Cancel = True" nimmst du mit rein, damit er nicht in den Bearbeitungsmodus der Zelle geht.

[Elex]

Hi

bei mir funktioniert dein Code wenn ich den Blättern die Namen gebe.

An Hand deiner Vorgaben ergibt sich das B13:C13 eine verbundene Zelle ist?
Wenn das nicht so ist, dann musst du Case ändern.

Dein Code gekürzt. (funktioniert genau so) 

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Select Case Target.Address(False, False)
     Case "B13:C13"
          Sheets("Notes Sighting-Round").Range("B9").Value = Range("B13").Value
   End Select
End Sub

PS: Also den Code. @Case lassen wir wie er ist. :19:

[00202]

Hallo Elex, :19:

bei verbundenen Zellen - Einverstanden. :21:

[elamigo]

Hab beides nochmals versucht und keine Erfolg erzielen können, habe mich dann mal lieber an eine BSP-Datei gemacht, bevor es noch ewig hin und her geht.   

Das Problem bleibt das selbe. Kopieren geht allerdings ist es das Format was mir am Ende nicht mehr passt. Aber ich denke das seht ihr dann selber....

anbei die Datei.

[Elex]

Hi

erstmal sollte es so klappen.

Code:

        Case "B13:C13"
            .Range("B13").Copy
           Sheets("Notes Sighting-Round").Range("B9").PasteSpecial (xlPasteValuesAndNumberFormats)

Wenn ich oder ein anderer dann noch Zeit finde, ist der Code im ganzen dann zusammenzufassen.
Ich würde erst heute Abend dazu kommen.

Gruß Elex

PS: Oder soll die Formel rüber und nicht nur der Inhalt?

[elamigo]

Wenn du den Code natürlich mit irgendeiner Schleife, oder wie auch immer, zusammenfassen kannst, dann nehme ich es natürlich mit Handkuss 

Teste gleich deinen Code.

[Kuwer]

Wenn ich oder ein anderer dann noch Zeit finde, ist der Code im ganzen dann zusammenzufassen.
Ich würde erst heute Abend dazu kommen.

Ich übernehme mal, da ich es schon fertig habe:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 With Worksheets("Notes Sighting-Round")
   If Not Application.Intersect(Target, Range("B13:C56")) Is Nothing Then
     Cancel = True
     .Cells(Target.Row - 4, 2).Value = Target.Value
   End If
   If Not Application.Intersect(Target, Range("E13:F56")) Is Nothing Then
     Cancel = True
     .Cells(Target.Row - 4, 4).Value = Target.Value
   End If
 End With
End Sub

Gruß Uwe