title image


Smiley Erstellen einer "Buchhalternase"
Hallo Christina Verena,



hier die Lösung:



So sieht die Tabelle aus:



 ABCD5A          Bilanz zum 31.12... P6Grundstücke und Bauten1,00  Eigenkapital1,00 Â€7TA und Maschinen1,00  V. gegenüber Kreditinst.1,00 Â€8andere Anlagen und BGA1,00  V. a. LL.1,00 Â€9Roh- Hilfs. und Betriebsst.1,00  Wechselverbindlichkeiten6,00 Â€10Unfertige Erzeugnisse1,00    11Fertige Erzeugnisse1,00    12F. a. LL.1,00    13Kassenbestand1,00    14Bankguthaben1,00    15    16 =SUMME(B6:B14) =SUMME(D6:D14)



Der Cursor muss in der "Innenecke" der Tabelle stehen (hier C10) die Nase wird dann so weit erstellt wie nach rechts und nach unten Zellen beschrieben sind (hier C14 / D10). Spaltenbreite und Zeilenhöhe werden dabei berücksichtigt (siehe Kommentare im Code)







      

Sub erstellenBuchhalternase()

Dim Zelle1 As Range

Set Zelle1 = ActiveCell



    'Schleife um die Breite zu ermitteln die gewünscht wird

    'Hier so weit nach rechts wie Zellen eine Zeile höher ausgefüllt sind

    For i = Zelle1.Column To Cells(Zelle1.Row - 1, 256).End(xlToLeft).Column

        Breite = Breite + Cells(1, i).Width

    Next

    FaktorBreite = Breite / 60 ' Die Breite der Nase wird später BEIM ERSTELLEN 60 sein

    

    'Wie vor für die Höhe. Nur nach links und nach unten

    For i = Zelle1.Row To Cells(Zelle1.Row, Zelle1.Column - 1).End(xlDown).Row

        höhe = höhe + Cells(i, Zelle1.Column).Height

    Next

    'von der höhe je die hälfte der ersten und letzten zeile abziehen (falls diese ungleich hoch sind)

    höhe = höhe - Zelle1.Height / 2 _

    - Cells(Cells(Zelle1.Row, Zelle1.Column - 1).End(xlDown).Row, Zelle1.Column - 1).Height / 2

    FaktorHöhe = höhe / 12.75

    'Buchhalternase erstellen mit Höhe 12,75 u. Breite 60

    With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, 60#, 270#)

        .AddNodes msoSegmentLine, msoEditingAuto, 72.75, 270#

        .AddNodes msoSegmentLine, msoEditingAuto, 108.75, 257.25

        .AddNodes msoSegmentLine, msoEditingAuto, 120#, 257.25

        .ConvertToShape.Select

    End With

    Selection.ShapeRange.Top = Zelle1.Top + Zelle1.Height / 2 'Position oben bestimmen. Hier Mitte der aktiven Zelle

    Selection.ShapeRange.Left = Zelle1.Left 'Position links bestimmen. Hier linker Zellrand

    Selection.ShapeRange.ScaleHeight FaktorHöhe, msoFalse, msoScaleFromTopLeft 'Höhe gemäß Faktor manipulieren

    Selection.ShapeRange.ScaleWidth FaktorBreite, msoFalse, msoScaleFromTopLeft 'Breite gemäß Faktor manipulieren

    Zelle1.Select ' Aktivierung des Shapes aufheben

End Sub 





Code eingefügt mit Syntaxhighlighter 3.0







Wenn Du den Code schrittweise ausführst und mal die "Nase" beobachtest dann wird die Wirkungsweise der Manipulation von Zeichnungsobjekten am sichtbarsten.



lg Georg


Beiträge zu Excel 2002 in Verbindung mit Win XP

 A
1Tabellentool
2von StrgAltEntf


Gibts hier


geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: