Thema: Makro optimieren | Herbers Excel-Forum

Hallo zusammen,
habe bereits das Makro aufgezeichnet und angepasst, nun hätte ich’s
gerne etwas optimiert, wenn’s geht.
Der Bereich ("A3:A8") wird in Abhängigkeit des Target-Wertes kopiert
z. B. beim Wert 2 in ("A5:A15") beim Wert 3 in ("A5:A15") und ("A17:A22")
u.s.w…

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Address = "$K$10" And Not IsEmpty(Target) = True Then
If Target.Value = 2 Then
Range("A3").Select
Range("A3:A8").Copy
ActiveCell.Offset(7, 0).PasteSpecial
ElseIf Target.Value = 3 Then
Range("A3").Select
Range("A3:A8").Copy
ActiveCell.Offset(7, 0).PasteSpecial
ActiveCell.Offset(7, 0).PasteSpecial
ElseIf Target.Value = 4 Then
Range("A3").Select
Range("A3:A8").Copy
ActiveCell.Offset(7, 0).PasteSpecial
ActiveCell.Offset(7, 0).PasteSpecial
ActiveCell.Offset(7, 0).PasteSpecial
ElseIf Target.Value = 5 Then
Range("A3").Select
Range("A3:A8").Copy
ActiveCell.Offset(7, 0).PasteSpecial
ActiveCell.Offset(7, 0).PasteSpecial
ActiveCell.Offset(7, 0).PasteSpecial
ActiveCell.Offset(7, 0).PasteSpecial
ElseIf Target.Value = 6 Then
Range("A3").Select
Range("A3:A8").Copy
ActiveCell.Offset(7, 0).PasteSpecial
ActiveCell.Offset(7, 0).PasteSpecial
ActiveCell.Offset(7, 0).PasteSpecial
ActiveCell.Offset(7, 0).PasteSpecial
ActiveCell.Offset(7, 0).PasteSpecial
End If
End If
Application.CutCopyMode = False
End Sub

Vorab vielen Dank für die Hilfe.
Grüße

Hallo Edie,
ungetestet:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim lngOffset As Long
With Target
If .Address = "$K$10" Then
If .Value >= 2 And .Value <= 6 Then
If Int(.Value) = .Value Then
Range("A3:A8").Copy
For lngOffset = 1 To .Value - 1
Cells(3 + lngOffset * 7, 1).PasteSpecial
Next
End If
End If
End If
End With
Application.CutCopyMode = False
End Sub

Gruß Gerd

Hi edie,

Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim i As Integer, n As Integer If Target.Address = "$K$10" And IsNumeric(Target) Then   If Target > 1 And Target < 7 Then     n = 3     For i = 1 To Target.Value       Range("A3:A8").Copy       Range("A" & n & ":A" & n + 5).PasteSpecial xlPasteValues       n = n + 7     Next   End If End If Application.CutCopyMode = False End Sub Gruß Jürgen AW: Etwas optimiert edie Hallo Gerd L, Hallo Backowe, bin immer wieder überrascht, klappt wunderbar, vielen herzlichen Dank. Danke und einen schönen Abend noch. Grüße