AW: Checkbox kopieren m. Makro u. Zellverknüpfung +1
25.09.2014 15:26:40
fcs
Hallo Thomas,
wenn du einen beliebigen Zeilenblock kopieren und unterhalb einfügen willst, dann wird es etwas komplizierter. Es ist aber nicht unbedingt erforderlich, die Zeilen zu einer Checkbox ggf. erst einzublenden. Man kann es auch so steuern, dass erst in den kopierten Zeilen die Zeilen ggf. eingeblendet werden.
Gruß
Franz
Sub Kopie_3_Zeilen()
Dim Zeile As Long, objShape As Shape
Dim wks As Worksheet
Set wks = ActiveSheet
Zeile = ActiveCell.Row
'Checkbox in Spalte A in der Zeile mit der aktiven Zelle suchen
Set objShape = fncFindCheckbox(objWks:=wks, Zeile:=Zeile, Spalte:=1)
If objShape Is Nothing Then
MsgBox "Keine Checkbox in aktiver Zeile. " _
& "Bitte Zelle in Zeile mit Checkbox selektieren"
Else
With wks
If Application.CopyObjectsWithCells = False Then _
Application.CopyObjectsWithCells = True
'Zeilen kopieren und unterhalb des Blocks einfügen
.Range(.Rows(Zeile), .Rows(Zeile + 2)).Copy
.Range(.Rows(Zeile + 3), .Rows(Zeile + 5)).Insert
Zeile = Zeile + 3
'Prüfen, ob Checkbox deaktiviert ist
If objShape.ControlFormat.Value = -4146 Then
'kopierte Checkbox suchen
Set objShape = fncFindCheckbox(objWks:=wks, Zeile:=Zeile, Spalte:=1)
'Neue Checkbox auf True setzen und Zeilen einblenden
objShape.ControlFormat.Value = 1
.Cells(Zeile, 1) = True
.Range(.Rows(Zeile + 1), .Rows(Zeile + 2)).EntireRow.Hidden = False
End If
'Zelle in kopiertem Block selektieren
Cells(Zeile, 2).Select
'Altdaten in koierten Zeilen löschen --- ggf. weglassen
.Range(.Cells(Zeile, 2), .Cells(Zeile + 2, 10)).ClearContents
End With
End If
End Sub
Public Function fncFindCheckbox(objWks As Worksheet, Zeile As Long, _
Optional Spalte As Long = 1) As Shape
'Checkbox finden mit TopLeftCell in der Zeile und Spalte
Dim objShape As Shape
For Each objShape In objWks.Shapes
With objShape
'Prüfen der Steuerelementeigenschaften
If .TopLeftCell.Column = Spalte Then
If .TopLeftCell.Row = Zeile Then
If .Type = msoFormControl Then
If .FormControlType = xlCheckBox Then
Set fncFindCheckbox = objShape
Exit For
End If
End If
End If
End If
End With
Next
End Function