Bitte um Hilfe - kopieren in andere Tabelle
15.06.2015 16:46:56
Hoffmann
ich brauche wieder Hilfe, da ich kurz vorm irre werden bin.
Bei Doppelklick in eine Zeile soll unabhängig vom Tabellenblatt der Bereich C:G in die nächste freie Zeile (Prüfung ab B17, A ist leer)in ein anderes Tabellenblatt ("DB") kopiert werden. Erst wurde aufwärts statt abwärts ab B eingefügt, dann richtig rum ab B und nun ab C, aber er überschreibt und wählt nicht mehr die nächste freie Zeile. Kann mir bitte jemand sagen, wo im Code der Fehler ist? Mit Chat-Beispielen und probieren bin ich leider nicht weiter gekommen.
So ist der Stand:
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel _
_
As Boolean)
'If WorksheetFunction.CountA(Sheets("DB").Range("B17:B50")) = 40 Then MsgBox "Zielbereich voll": _
_
Exit Sub
'With Sh
'Select Case .Name
'bei definierten Blattnamen
'Case "Dämmung", "Arbeitsschutz", "Bleche", "Normteile", "Werkzeug", "FuKB"
'wenn nicht in eine Zelle im Bereich L2:L3000 geklickt wurde, dann Makro verlassen
'If Intersect(.Range("$L$2:$L$3000"), Target) Is Nothing Then Exit Sub
'Bereich c:g der Zeile, in die geklickt wurde, kopieren
'.Range(.Cells(Target.Row, 3), .Cells(Target.Row, 7)).Copy
'Im Blatt ARV1 in Spalte c:g anfuegen
'Sheets("ARV1").Cells(Sheets("ARV1").Cells(Rows.Count, 3).End(xlUp).Offset(1)).PasteSpecial
'Sheets("ARV1").Cells((50), Sheets("ARV1").Cells(49, 3).End(xlUp).Row + 1).PasteSpecial
'Kopiermodus beenden
'Application.CutCopyMode = False
'Cancel = True
'End Select
'End With
'End Sub
'mit dem aktiven Blatt
Dim lngz As Long
With Sheets("ARV1")
lngz = Sheets("ARV1").Range("B50").End(xlUp).Row
End With
If lngz With Sh
'Aktion ausführen, wenn Blattname = ...
Select Case .Name
'bei definierten Blattnamen
Case "Dämmung", "Arbeitsschutz", "Bleche", "Normteile", "Werkzeug", "FuKB"
'wenn nicht in eine Zelle im Bereich L2:L3000 geklickt wurde, dann Makro verlassen
If Intersect(.Range("$L$2:$L$3000"), Target) Is Nothing Then Exit Sub
'Bereich c:g der Zeile, in die geklickt wurde, kopieren
.Range(.Cells(Target.Row, 3), .Cells(Target.Row, 7)).Copy
'Im Blatt ARV1 in Spalte c:g anfuegen
Sheets("ARV1").Cells(lngz + 2, 3).PasteSpecial
'End(xlUp).Row + 1,3)
'Sheets("ARV1").Cells(Sheets("ARV1").Cells(Rows.Count, 3).End(xlUp).Row + 1).PasteSpecial
'Kopiermodus beenden
Application.CutCopyMode = False
'Klickzelle verlassen
Cancel = True
'Ende Aktion ausführen, wenn Blattname = ...
End Select
'Ende mit dem aktiven Blatt
End With
Else
MsgBox "Alle Zeilen im Formular schon belegt!" & vbLf _
& vbLf & "Auswahl wird nicht übertragen!"
End If
End Sub
Vielen Dank im Voraus für Eure Hilfe.