AW: Zeilen per VBA einfügen, bestimmte Werte kopieren!
24.04.2015 06:38:38
Werner
Hallo Steve,
da hast du ja was von mir ausgegraben.
Geändert ist jetzt: Die Zellwerte werden mit übernommen. Die Werte in der eingefügten Zeile werden kursiv und rot formatiert (komplette Zeile).
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean)
Dim zeilenanzahl As Long
Dim x As Integer
Dim i As Integer
x = 1
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'#### Doppelklick in Spalte A ab Zeile 4, ggf. anpassen ####
If Target.Column = 1 And Target.Row > 3 Then
'#### Tabellenblatt und Passwort anpassen ####
Worksheets("Prozessbewertung").Unprotect Password:="Andreas"
On Error GoTo Notausgang
zeilenanzahl = InputBox("Wieviel Zeilen?", "Zeilen einfügen")
With ActiveCell
For i = 1 To zeilenanzahl
If ActiveCell = "" Then
.EntireRow.Copy
.EntireRow.Offset(x, 0).Insert shift:=xlDown
.EntireRow.Offset(x, 0).PasteSpecial
Else
.EntireRow.Copy
.EntireRow.Offset(x, 0).Insert shift:=xlDown
.EntireRow.Offset(x, 0).PasteSpecial
.EntireRow.Offset(x, 0).Font.Italic = True
.EntireRow.Offset(x, 0).Font.ColorIndex = 3
ActiveCell.Offset(-x, 0).Select
End If
x = x + 1
Next i
.Offset(1, 0).Select
End With
'#### Tabellenblatt und Passwort anpassen ####
Sheets("Prozessbewertung").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, _
AllowFormattingCells:=True, AllowFormattingRows:=True, AllowFormattingColumns:=True, _
AllowInsertingColumns:=True, AllowSorting:=True, AllowFiltering:=True, _
Password:="Andreas"
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Notausgang:
cancel = True
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'#### Tabellenblatt und Passwort anpassen ####
Sheets("Prozessbewertung").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, _
AllowFormattingCells:=True, AllowFormattingRows:=True, AllowFormattingColumns:=True, _
AllowInsertingColumns:=True, AllowSorting:=True, AllowFiltering:=True, _
Password:="Andreas"
End If
End Sub
Gruß Werner