Dynamisch erstelle Shapes mit Makro-Funktion

[d'r Bastler]

Moin allerseits,
Shapes werden von M$ in jeder Office-Anwendung angeboten wie Sauerbier und ich kann mich kaum erinnern jemals welche außerhalb PowerPoint eingesetzt zu haben. Allerdings sind sie natürlich ein probates Mittel, um z.B. Spielflächen abzubilden, ob ein Dartboard, ein Spielfeld für Basket-/Fuß-/Handball usw. Von den vielen Brettspielen mal ganz zu schweigen.

Diese kleinen Bildchen von Hand an ihre jeweilige Position zu schubsen, ist allerdings ziemlich mühsam, weshalb ich hier mal erste vier Konstruktionen vorstellen möchte, die auf im Code gelisteten Parametern basieren. Verwendet habe ich ein paar Basis-Shapes, denen neben ihren Positionsangaben Left und Top noch Height und Width leicht zugewiesen werden können. Anspruchsvoller werden dann Parameter wie IncrementRotation und Adjustment.Item(x). Dazu aber später mehr.

Um die Shapes nicht nur dekorativ sein zu lassen, werden ihnen automatisch generierte Namen und eine Universalmakro zugewiesen. Zur Veranschaulichung, wie die Spielbretter denn aufgebaut werden, habe ich eine kleine Code-Verzögerung eingebaut, die man natürlich auskommentieren kann. Sie bewirkt -salopp gesagt- kleine Animationen. Der Code dieser von allen Shapes genutzten zwei Subs, die in ein eigenes Modul gehören, dann mal hier:

Code: Alles auswählen

Option Explicit

Private Sub ClickOnShape()
    MsgBox ActiveSheet.Shapes(Application.Caller).Name
End Sub

Sub ShowTime(sgDelay As Single)
Dim sgShow As Single
'sgDelay = 0.05 = 0,05 Sekunden
sgShow = Timer + sgDelay
    Do While Timer < sgShow
        DoEvents
    Loop
End Sub

Die MessageBox zeigt welche Informationen vom ClickOnShape denn übermittelt werden. Wenn mein Shape z.B. D_12 heißt, kann ich daraus für ein Dartboard schon sehen: es wurde ein Doppel-12 geworfen, womit die Bedingungen für die Ermittlungen des Wertes und ggf. Double In/Out erkennbar sind. Wie das genau zu nutzen ist, beschreibe ich dann in einem eigenen Beitrag am fertigen Dartboard.

Hier kommt nun erst einmal die Grundlage dafür: Ein Kreis, der sich aus gleich breiten Segmenten zusammensetzt. Man achte auf die Kommentare im Code, die auch Hinweise für eigene Experimente sind: Stichwort ANPASSEN.

Code: Alles auswählen

Sub MakeDarts() 'Tortenstücke, Darts
Dim shp As Shape
Dim i As Integer, c As Integer, a As Integer, aRainbow
Dim iLeft As Integer, iTop As Integer, iWidth As Integer, iHeight As Integer    'fixe Parameter
Dim iAngle As Integer, iSegments As Integer, iAdjust As Integer                 'dynamische Parameter

aRainbow = Array(Array(255, 0, 0), Array(255, 146, 0), Array(255, 255, 0), Array(240, 240, 240), Array(0, 212, 28), Array(0, 68, 220), Array(128, 0, 128))

For Each shp In ActiveSheet.Shapes
    If Left(shp.Name, 3) = "Arc" Then
        shp.Delete
    End If
Next
                                                        'ANPASSEN
iLeft = 175: iTop = 145: iWidth = 100: iHeight = 100    'wo soll die Torte denn hin?
iSegments = 12                                          'wie klein dürfen die "Tortenschnipsel zu EUR 4,80 & Draußen nur Kännchen" denn sein?
iAdjust = 360 / iSegments * (-1) - 2                    '-2 sorgt für eine kleine Überlappung, um Spalten zu vermeiden

With ActiveSheet
    a = -1
    For i = 1 To iSegments
    a = a + 1
    If a > UBound(aRainbow) Then
        a = 0
    End If
    iAngle = 360 / iSegments * i
            .Shapes.AddShape(msoShapeArc, iLeft, iTop, iWidth, iHeight).Select
            With Selection.ShapeRange.Fill
                .Visible = msoTrue
                .ForeColor.RGB = RGB(aRainbow(a)(0), aRainbow(a)(1), aRainbow(a)(2))    'hier deine Array-basierte Farbgebung (Regenbogenfahne +  weiß)
                .Transparency = 0
                .Solid
            End With
            With Selection.ShapeRange
                .Name = "Arc " & i
                .IncrementRotation iAngle - 90 + iAdjust / 2    ' + iAdj/2 zentriert das erste Sahnestück über dem Zentrum
                .Adjustments.Item(1) = iAdjust
            End With
    ShowTime 0.01
    Next i

    For Each shp In ActiveSheet.Shapes                          'hier bekommen ALLE Shapes ihr Fett weg = ihr Universal-Makro verpasst
        shp.OnAction = "ClickOnShape"
    Next
    .Cells(1, 1).Select
End With

End Sub

Was die Färbung der Shapes betrifft, habe ich hier drei Varianten im Angebot: Die Farbwerte kommen aus einem Array, werden abwechselnd gesetzt oder fix definiert. Nachdem alle Beispiele Ergebnis von Schleifen sind, kann man aber z.B. auch Farbwerte RGB durch Multiplikatoren definieren.

Und jetzt ein langweiliges Schachbrett. Hier taucht die erste Abweichung von den vier Positionsparametern auf. Mit iOffset wird ein horizontaler Versatz erzeugt, die Zeile einfach durch Addition der Shape-Höhe. Nachdem dazu mehrere Schleifen (bzw. eine geschachtelte) notwendig sind, kann der Shape-Name nicht mehr aus dem einfachen Iterator wie beim Kreis erzeugt werden, sondern benötigt einen eigenen Zähler.

Code: Alles auswählen

Sub MakeChess() ' => Schach
Dim shp As Shape
Dim i As Integer, a As Integer, c As Integer, r As Integer, iOffset As Integer      'dynamische Parameter
Dim iLeft As Integer, iTop As Integer, iWidth As Integer, iHeight As Integer        'fixe Parameter

For Each shp In ActiveSheet.Shapes
    If Left(shp.Name, 4) = "Rect" Then
        shp.Delete
    End If
Next
                                                        'ANPASSEN
iLeft = 350: iTop = 50: iWidth = 50: iHeight = 50       'wo soll das erste Segment wie hoch und breit denn hin?
iOffset = iLeft

With ActiveSheet                                        'ANPASSEN
    c = 1               'Spalten und Zeilenzähler als Index für die Farbe
    For a = 1 To 8                                      'Anzahl der Zeilen
            For i = 1 To 8                              'Anzahl der Spalten
            r = r + 1   'Feldzähler als Index für den Namen
            c = c + 1
                    .Shapes.AddShape(msoShapeRectangle, iOffset, iTop, iWidth, iHeight).Select
                    With Selection.ShapeRange.Fill
                        .Visible = msoTrue
                        .ForeColor.RGB = RGB(245, 245, 220)     'hier eine abwechselnde Farbgebung
                            If c Mod 2 = 0 Then
                                .ForeColor.RGB = RGB(245, 150, 100)
                            End If
                        .Transparency = 0
                        .Solid
                    End With
                    With Selection.ShapeRange
                        .Name = "Rect " & r
                    End With
            iOffset = iOffset + iWidth
            ShowTime 0.01
            Next i
        
            iOffset = iLeft
            iTop = iTop + iHeight
            c = c + 1
    ShowTime 0.01
    Next a

    For Each shp In ActiveSheet.Shapes                          'hier bekommen ALLE Shapes ihr Fett weg = ihr Universal-Makro verpasst
        shp.OnAction = "ClickOnShape"
    Next
    .Cells(1, 1).Select
End With

End Sub

Das nächste ist eine nette Kombination aus den bisher verwendeten Shapes mit einem dritten Kollegen. Ein Tavla- oder Backgammon-Board mit Rahmen. Auch hier wird wieder ein dedizierter Zähler für die Shape-Namen benötigt.

Code: Alles auswählen

Sub MakeTavla() 'Dreiecke mit Rahmen => Backgammon
Dim shp As Shape
Dim i As Integer, c As Integer, iOffset As Integer
Dim iLeft As Integer, iTop As Integer, iWidth As Integer, iHeight As Integer    'fixe Parameter
Dim iAngle As Integer, iSegments As Integer, iAdjust As Integer                 'dynamische Parameter

For Each shp In ActiveSheet.Shapes
    If Left(shp.Name, 4) = "Back" Then
        shp.Delete
    End If
Next

With ActiveSheet
    'Board Hintergrund
    iLeft = 825: iTop = 65: iWidth = 520: iHeight = 350
        .Shapes.AddShape(msoShapeRectangle, iLeft, iTop, iWidth, iHeight).Select
        With Selection.ShapeRange.Fill
            .Visible = msoTrue
            .ForeColor.RGB = RGB(139, 69, 19)
            .Transparency = 0
            .Solid
        End With
        With Selection.ShapeRange
            .Name = "Back"
        End With

    iLeft = 800: iTop = 70: iWidth = 30: iHeight = 120
    iSegments = 24
    
    ShowTime 0.01
    'Board oben links
    For i = 1 To iSegments / 4
    c = c + 1
        iOffset = iLeft + 40 * i
            .Shapes.AddShape(msoShapeIsoscelesTriangle, iOffset, iTop, iWidth, iHeight).Select
            With Selection.ShapeRange.Fill
                .Visible = msoTrue
              .ForeColor.RGB = RGB(245, 245, 220)     'hier eine abwechselnde Farbgebung
                If i Mod 2 = 0 Then
                    .ForeColor.RGB = RGB(245, 150, 100)
                End If
                .Transparency = 0
                .Solid
            End With
            With Selection.ShapeRange
                .Name = "Back " & c
                .IncrementRotation 180
            End With
    ShowTime 0.01
    Next i
    

    'Board oben rechts
    iLeft = iLeft + 260
    For i = 1 To iSegments / 4
    c = c + 1
        iOffset = iLeft + 40 * i
            .Shapes.AddShape(msoShapeIsoscelesTriangle, iOffset, iTop, iWidth, iHeight).Select
            With Selection.ShapeRange.Fill
                .Visible = msoTrue
              .ForeColor.RGB = RGB(245, 245, 220)     'hier der Trick für eine abwechselnde Farbgebung
                If i Mod 2 = 0 Then
                    .ForeColor.RGB = RGB(245, 150, 100)
                End If
                .Transparency = 0
                .Solid
            End With
            With Selection.ShapeRange
                .Name = "Back " & c
                .IncrementRotation 180
            End With
    ShowTime 0.01
    Next i
    
    'Board unten links
    iTop = iTop + 220
    iLeft = iLeft - 260
    For i = 1 To iSegments / 4
    c = c + 1
        iOffset = iLeft + 40 * i
            .Shapes.AddShape(msoShapeIsoscelesTriangle, iOffset, iTop, iWidth, iHeight).Select
            With Selection.ShapeRange.Fill
                .Visible = msoTrue
              .ForeColor.RGB = RGB(245, 150, 100)     'hier eine abwechselnde Farbgebung
                If i Mod 2 = 0 Then
                    .ForeColor.RGB = RGB(245, 245, 220)
                End If
                .Transparency = 0
                .Solid
            End With
            With Selection.ShapeRange
                .Name = "Back " & c
                .IncrementRotation 0
            End With
    ShowTime 0.01
    Next i
    
    'Board unten rechts
    iLeft = iLeft + 260
    For i = 1 To iSegments / 4
    c = c + 1
        iOffset = iLeft + 40 * i
            .Shapes.AddShape(msoShapeIsoscelesTriangle, iOffset, iTop, iWidth, iHeight).Select
            With Selection.ShapeRange.Fill
                .Visible = msoTrue
              .ForeColor.RGB = RGB(245, 150, 100)     'hier eine abwechselnde Farbgebung
                If i Mod 2 = 0 Then
                    .ForeColor.RGB = RGB(245, 245, 220)
                End If
                .Transparency = 0
                .Solid
            End With
            With Selection.ShapeRange
                .Name = "Back " & c
                .IncrementRotation 0
            End With
    ShowTime 0.01
    Next i
    
    'Rahmen links
    iLeft = 825: iTop = 65: iWidth = 260: iHeight = 350
    .Shapes.AddShape(msoShapeFrame, iLeft, iTop, iWidth, iHeight).Select
                With Selection.ShapeRange.Fill
                .Visible = msoTrue
                .ForeColor.RGB = RGB(195, 100, 50)
                .Transparency = 0
                .Solid
            End With
            With Selection.ShapeRange
                .Name = "Back li"
                .IncrementRotation 0
                .Adjustments.Item(1) = 0.03
            End With
            
    ShowTime 0.01
    'Rahmen rechts
    iLeft = 1085: iTop = 65: iWidth = 260: iHeight = 350
    .Shapes.AddShape(msoShapeFrame, iLeft, iTop, iWidth, iHeight).Select
                With Selection.ShapeRange.Fill
                .Visible = msoTrue
                .ForeColor.RGB = RGB(195, 100, 50)
                .Transparency = 0
                .Solid
            End With
            With Selection.ShapeRange
                .Name = "Back re"
                .IncrementRotation 0
                .Adjustments.Item(1) = 0.03
            End With


    For Each shp In ActiveSheet.Shapes                          'hier bekommen ALLE Shapes ihr Fett weg = ihr Universal-Makro verpasst
        shp.OnAction = "ClickOnShape"
    Next
    .Cells(1, 1).Select
End With    'ActiveSheet

End Sub

Bisher liegen alle drei Gebilde so nebeneinander, dass sie gut auf einem Büro-üblichen Bildschirm passen. Mit dem letzten Beispiel wird das Schachbrett überlagert, nämlich mit einem Mühle-Brett, das sich gerne auf der Rückseite von Schach-/Dame-Brettern befindet. Verwendet werden nur zwei monochrome Shapes

Code: Alles auswählen

Sub MakeNine() '=> Mühle: Nine men's morris
Dim shp As Shape
Dim i As Integer, a As Integer, sgAdjust As Single
Dim iLeft As Integer, iTop As Integer, iWidth As Integer, iHeight As Integer        'fixe Parameter

For Each shp In ActiveSheet.Shapes
    If Left(shp.Name, 4) = "Mill" Then
        shp.Delete
    End If
Next

iLeft = 350: iTop = 50: iWidth = 400: iHeight = 400
sgAdjust = 0.03

With ActiveSheet
    'drei Rahmen
    For i = 1 To 3
        a = a + 1
        .Shapes.AddShape(msoShapeFrame, iLeft, iTop, iWidth, iHeight).Select
                    With Selection.ShapeRange.Fill
                    .Visible = msoTrue
                    .ForeColor.RGB = RGB(0, 0, 0)
                    .Transparency = 0
                    .Solid
                End With
                With Selection.ShapeRange
                    .Name = "Mill " & a
                    .IncrementRotation 0
                    .Adjustments.Item(1) = sgAdjust
                End With
        
        iLeft = iLeft + 50
        iTop = iTop + 50
        iWidth = iWidth - 100
        iHeight = iHeight - 100
        sgAdjust = sgAdjust + 0.01
    ShowTime 0.1
    Next i
    
 	'je zwei waage-/senkrechte Linien (Rechtecke)   
iLeft = 550: iTop = 50: iWidth = 10: iHeight = 110
        a = a + 1
        .Shapes.AddShape(msoShapeRectangle, iLeft, iTop, iWidth, iHeight).Select
                    With Selection.ShapeRange.Fill
                    .Visible = msoTrue
                    .ForeColor.RGB = RGB(0, 0, 0)
                    .Transparency = 0
                    .Solid
                End With
                With Selection.ShapeRange
                    .Name = "Mill " & a
                    .IncrementRotation 0
                End With
    ShowTime 0.1
iLeft = 550: iTop = 340: iWidth = 10: iHeight = 110
        a = a + 1
        .Shapes.AddShape(msoShapeRectangle, iLeft, iTop, iWidth, iHeight).Select
                    With Selection.ShapeRange.Fill
                    .Visible = msoTrue
                    .ForeColor.RGB = RGB(0, 0, 0)
                    .Transparency = 0
                    .Solid
                End With
                With Selection.ShapeRange
                    .Name = "Mill " & a
                    .IncrementRotation 0
                End With
    ShowTime 0.1
iLeft = 400: iTop = 195: iWidth = 10: iHeight = 110
        a = a + 1
        .Shapes.AddShape(msoShapeRectangle, iLeft, iTop, iWidth, iHeight).Select
                    With Selection.ShapeRange.Fill
                    .Visible = msoTrue
                    .ForeColor.RGB = RGB(0, 0, 0)
                    .Transparency = 0
                    .Solid
                End With
                With Selection.ShapeRange
                    .Name = "Mill " & a
                    .IncrementRotation 90
                End With
    ShowTime 0.1
iLeft = 690: iTop = 195: iWidth = 10: iHeight = 110
        a = a + 1
        .Shapes.AddShape(msoShapeRectangle, iLeft, iTop, iWidth, iHeight).Select
                    With Selection.ShapeRange.Fill
                    .Visible = msoTrue
                    .ForeColor.RGB = RGB(0, 0, 0)
                    .Transparency = 0
                    .Solid
                End With
                With Selection.ShapeRange
                    .Name = "Mill " & a
                    .IncrementRotation 90
                End With

    For Each shp In ActiveSheet.Shapes                          'hier bekommen ALLE Shapes ihr Fett weg = ihr Universal-Makro verpasst
        shp.OnAction = "ClickOnShape"
    Next
    .Cells(1, 1).Select
End With
End Sub

Für alle Beispiele achte man auf die vergebenen Namen der Shapes. Sie dienen als Filter, um die Shapes beim Experimentieren gezielt zu löschen - oder eben später für entsprechende Makros zu nutzen.

Nun zu den 2^nd Level-Parametern:
IncrementRotation überrascht bei jedem Shape wieder mit seinem Nullpunkt. Hat man den ermittelt, lässt sich die Drehung relativ leicht definieren. Im ersten Beipiel z.B als Formel: 360 Grad, dividiert durch die Anzahl der Segmente. Hier habe ich das erste Mal Adjust verwendet, um das erste Segment über dem Mittelpunkt des Kreises zu zentrieren.
Adjustments.Item(x) spielt dann eine Rolle, wenn Shapes im Verhältnis zu ihrem von M$ definierten Original z.B. gestreckt oder gestaucht werden sollen. Bei Frames kann man darüber z.B. die Dicke der Rahmenlinien steuern.

Packt man diese Snippets in ein eigenes Modul, kann mit den folgenden beiden hübsch aufräumen, einzelne Beispiele oder auch die komplette Show zeigen. Bequemer Aufruf dann über Alt-F8.

Code: Alles auswählen

Option Explicit

Sub Clear() ' d'r Tatortreiniger
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
    shp.Delete
Next
End Sub
Sub TheBigShow() 'd'r magische Bastler
Clear
MakeDarts
MakeChess
MakeTavla
MakeNine
MsgBox "Yeah man!"
End Sub

Leider sind die von M$ vergebenen Namen für die Shapes nicht wirklich leicht erkennbar, daher hier eine Liste der von mir verwendeten Suchbegriffe und M$-Ergebnisse:

#Shapes Quadrat, Rechteck = msoShapeRectangle
#Shapes Rahmen = msoShapeFrame
#Shapes symmetrisches Dreieck = msoShapeIsoscelesTriangle
#Shapes Kreissegment, Tortendiagramm = msoShapeArc
Für die Suchmaschinen:
#Makroaufruf zuordnen Caller, #Codeverzögerung Delay

Viel Spaß damit!
und schönen Tach noch!

[d'r Bastler]

Moin allerseits,
hier das zweite Kapitel meiner Shape-Schubserei. Ich wage mich jetzt an die Form Trapez. Das zu gestalten, benötigt neben den vier Basis-Werten mindestens einen 2nd-Level-Parameter Adjustments.Item(x) und ggf. noch IncrementRotation

Code: Alles auswählen

Sub MakeTrapezoids() 'Dart Doubles, Triples
Dim shp As Shape
Dim i As Integer, c As Integer, a As Integer
Dim iLeft As Integer, iTop As Integer, iWidth As Integer, iHeight As Integer    'fixe Parameter
Dim iAngle As Integer, iSegments As Integer, sgAdjust As Single                 'dynamische Parameter

For Each shp In ActiveSheet.Shapes
    If Left(shp.Name, 4) = "Trap" Then
        shp.Delete
    End If
Next

With ActiveSheet
        iLeft = 100: iTop = 50: iWidth = 100: iHeight = 50     'wo soll das erste Segment denn hin?
        sgAdjust = 0.7
        iAngle = 180
        
        .Shapes.AddShape(msoShapeTrapezoid, iLeft, iTop, iWidth, iHeight).Select
        With Selection.ShapeRange.Fill
            .Visible = msoTrue
            .ForeColor.RGB = RGB(50, 150, 100)
            .Transparency = 0
            .Solid
        End With
        With Selection.ShapeRange
            .Name = "Trap " & i
            .IncrementRotation iAngle                           'hier bitte kein eq, der Winkel bezieht sich auf die obere Breite und kann auch über 360 hinaus gesetzt werden
            .Adjustments.Item(1) = sgAdjust                     'der Wert zwischen 0 & 1 definiert das Verhältnis der unteren Breite des Trapezes zur oberen
        End With                                                'je höher der Wert der Nachkommastelle, desto kürzer der obere Schenkel

    For Each shp In ActiveSheet.Shapes                          'hier bekommen ALLE Shapes ihr Fett weg = ihr Universal-Makro verpasst
        shp.OnAction = "ClickOnShape"
    Next
    .Cells(1, 1).Select
End With

End Sub

Das nächste Kapitel wird dann (hoffentlich ) zeigen, wie man einen Ring aus Trapezen für ein Dart-Board baut.
Ich habe so etwas schon, aber höchst nervig aus Werten einer Tabelle und manuell justiert zusammengeschubst. Ergebnis: extrem holprig ...

Schönen Tach noch!

[xlKing]

Hi Bastler,

schön dass, ich dich hier und da ein bisschen unterstützen kann. Da ich im Lauf der Zeit auch schon so einige Shape-Landschaften erstellt habe, hier mal 2 kleine Tipps:

1. Mir fällt auf, dass du noch viel mit Select und Selection arbeitest. Das bringt den Bildschirm zum Zappeln. Deshalb sollte man das vermeiden. Ich nehme an, beim Arbeiten mi dem Range-Objekt verzichtest bereits darauf. Bei Shapes ist es ähnlich: AddShape ist eine Funktion die, so wie (fast) alle Add-Methoden das frisch erstellte Objekt, hier also das erstellte Shape zurückgibt. Du kannst also direkt mit With Activesheet.Shapes.AddShape() arbeiten. oder falls du später im Code nochmal auf das Shape zugreifen musst, dieses z.B. mit Set shp = Activesheet.shapes.AddShape() in eine Variable speichern.

2. Schlage ich vor, (kein Muss!) zusammengehörige Shapes entweder bei Erstellung oder am Ende zu gruppieren. Dann kannst du das erstellte Gebilde besser auf dem Blatt verschieben ohne es auseinander zu reißen. Oder du kannst (z.B. mit gedrückt gehaltener Shift-Taste) das Gebilder vergrößern oder verkleinern. Gruppieren mach ich meistens bereits in der Erstellschleife so:

ActiveSheet.Shapes.Range(Array(ActiveSheet.Shapes.Count, ActiveSheet.Shapes.Count - 1)).Group

Gruß Mr. K.

[d'r Bastler]

Moin Mr.K.

zu meiner Schande muss ich zugeben, dass meine Shape-Beispiele Makro-Recorder-basiert sind und daher diesen Selection-Müll mitbringen. Wo sonst immer ich kann, verzichte ich genau so gerne darauf, wie Du. Shapes sind für mich noch ziemliches Neuland, weswegen ich erst einmal auf die Recorder-Krücke zurückgegriffen habe. Danke für Deinen Hinwies!

Den Schritt, Shapes zu gruppieren (ich sehe den großen Vorteil!), habe ich als Nr. 3 auf meiner ToDo-Liste, denn erst einmal möchte ich ergründen, wie man denn Trapezoids (klingt wie ein Dino-Name ) per Formel so platzieren kann, dass sie 360° umschließen. Bei den Arc(heopterix) habe ich eine Formel gefunden, die anhand einer variablen Anzahl der Segmente die richtige Position findet. Bei den Traps bin ich noch am kämpfen.

Erlaube mir folgende kleine Anmerkung: "schön dass, ich dich hier und da ein..." Neenee Freund! Hier geht es nicht um mich, sondern darum, VBA-und XL-Wissen unters Volk zu bringen. Ich halte die Kombination XL/VBA für flächendeckend unterschätzt und möchte das ändern. Eigentlich müsste ich mich von M$ bezahlen lassen, statt das Ganze hier privat zu finanzieren ...

heb

Achso noch als Nachtrag: "Bildschirm zum zappeln." Das lässt sich mit Application.ScreenUpdating = true/false notfalls vermeiden.