VBA Script erstellen - automatische Tabelle erstellen

[koter]

Hallo phs,

...alles hier ist aus dem Internet zusammengesucht (Befehle), analysiert und für meine Zwecke angepasst( ausprobiert)

das mache ich auch oft so, man muss das Rad ja nicht immer neu erfinden.

Mein Ansatz wäre jetzt das ich die ActiveSelectionRange automatisch verändern will, sodass er ALLE Ellipsen auf dem Aktiven Baltt durchläuft...

In diesem Fall würde ich es ohne Auswahl (SelectionRange) versuchen und lieber den ShapeRange der aktiven Seite verwenden.

Hier ein Test mit X4 und Excel 2000:



Der Code:

Code:

Type Ellipsendaten
    Höhe As Double
    Breite As Double
    X As Double
    Y As Double
End Type
Dim Ellipsenzähler
Dim Ellipsenfeld() As Ellipsendaten

Sub eStart()
    ActiveDocument.Unit = cdrMillimeter 'die Maßeinheit des Dokuments einstellen
    Ellipsenzähler = 0
    Call EllipsenSuchen(ActivePage.Shapes.All)
    Call TabelleErstellen
    Debug.Print "Ende"
End Sub

Sub EllipsenSuchen(sr As ShapeRange)
    Dim s As Shape
    For Each s In sr
        Select Case s.Type
        Case cdrEllipseShape ' ist das Objekt eine Ellipse werden die Daten angelegt.
            Call DatenAnlegen(s)
        Case cdrGroupShape ' ist das Objekt eine Gruppe ruft sich die Sub selbst auf (Rekursion)
            Call EllipsenSuchen(s.Shapes.All)
        End Select
    Next
End Sub

Sub DatenAnlegen(s As Shape)
    ReDim Preserve Ellipsenfeld(Ellipsenzähler)
    
    s.GetSize _
        Ellipsenfeld(Ellipsenzähler).Breite, _
        Ellipsenfeld(Ellipsenzähler).Höhe
    s.GetPosition _
        Ellipsenfeld(Ellipsenzähler).X, _
        Ellipsenfeld(Ellipsenzähler).Y
        
    Ellipsenzähler = Ellipsenzähler + 1
End Sub

Private Sub TabelleErstellen()
    On Error GoTo Fehler 'Falls Excel nicht läuft, oder Keine Tabelle geöffnet ist, oder, oder...
    Dim XL As Object
    Set XL = GetObject(, "Excel.Application") 'Kontakt mit Excel aufnehmen
    Frage = MsgBox("Aktuelle Tabelle überschreiben?", vbYesNo + vbQuestion, "Excel")
    If Frage <> vbYes Then Exit Sub
    With XL.ActiveSheet ' Spaltenüberschriften setzen
        .Cells.Delete Shift:=xlUp ' Alle Zellen löschen
        .Cells(1, 1) = "Ellipsennummer"
        .Cells(1, 2) = "x - Position"
        .Cells(1, 3) = "y - Position"
        .Cells(1, 4) = "Höhe"
        .Cells(1, 5) = "Breite"
    End With
    With XL.ActiveSheet ' Daten Eintragen
        For i = 0 To Ellipsenzähler - 1
        .Cells(i + 2, 1) = i + 1
        .Cells(i + 2, 2) = Ellipsenfeld(i).X
        .Cells(i + 2, 3) = Ellipsenfeld(i).Y
        .Cells(i + 2, 4) = Ellipsenfeld(i).Höhe
        .Cells(i + 2, 5) = Ellipsenfeld(i).Breite
        Next i
        .Columns("A:E").EntireColumn.AutoFit  ' Spaltenbreite automatisch
        .Columns("B:E").NumberFormat = "0.00" ' Zahlenformat bestimmen
        .Rows("1:1").Font.FontStyle = "Bold"  ' Erste Zeile Fett
    End With

    Set XL = Nothing
    Exit Sub
Fehler: ' Fehlerbehandlung (Ausbaufähig)
    MsgBox "Irgendwas stimmt nicht!", vbCritical, "Fehler"
End Sub

Ich habe versucht die Subs und Variablen so zu benennen, dass man einigermaßen durchsteigen kann.

Vier Subs sind vielleicht ein wenig üppig, aber so lässt es sich wahrscheinlich am besten an Dein Vorhaben anpassen.

Vielleicht müssen ja noch Powerclips o. ä. berücksichtigt werden.

Willkommen im Forum!

Gruß

Koter

Nachtrag:
Excel muss laufen bevor das Makro gestartet wird!