Microsoft Excel

Herbers Excel/VBA-Archiv

Makro optimieren | Herbers Excel-Forum


Betrifft: Makro optimieren von: edie
Geschrieben am: 02.01.2010 22:31:22

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

  

Betrifft: AW: Makro optimieren von: Gerd L
Geschrieben am: 02.01.2010 23:12:02

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


  

Betrifft: Etwas optimiert von: Backowe
Geschrieben am: 02.01.2010 23:12:05

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

Code eingefügt mit Syntaxhighlighter 4.15


Gruß Jürgen


  

Betrifft: AW: Etwas optimiert von: edie
Geschrieben am: 02.01.2010 23:27:54

Hallo Gerd L,
Hallo Backowe,

bin immer wieder überrascht, klappt wunderbar, vielen herzlichen Dank.

Danke und einen schönen Abend noch.

Grüße