Office: Flächenberechnung des "Shapes" im Excel und Output in Zelle A1

Hallo Josef

Besten Dank für Deinen Lösungsvorschlag.

Wie funktioniert es eigentlich mit den Doppelflächen?

Wenn ich eine Fläche einfüge, die als Bezeichnung bereits vorhanden ist, kommt bei mir eine Fehlermeldung "Laufzeitfehler 70".

Wie hast du denn die Doppelflächen "Gebäudefläche" einfügen und die Flächen summieren können?

Gruss,
Robert

 

Hallo Robert,

in xl2010 können zwei Formen ohne Probleme den selben Namen tragen, evtl. geht das in xl2003 nicht.

Anbei die angepasste Datei, die Formen werden jetzt mit einer eindeutigen Nummer versehen, so sollte es ohne Probleme klappen.




« Gruß Sepp »

 

Vielen Dank Josef. Du hast mir hier sehr geholfen. *Smilie

Den Rest werde ich jetzt selber versuchen. *wink.gif*

LG,
Robert

 

Hallo Josef

Ich muss dich doch noch was fragen.*upps
Selbst habe ich schon einiges ausprobiert, jedoch ohne Erfolg. Das VBA Wissen ist bei mir doch noch sehr schwach. *frown.gif*

Ist es möglich den Code für die Flächenberechnung direkt in den Code für Hinzufügen neuer Shapes einzubinden. Habe hier folgendes versucht (siehe Code) es kommt aber immer eine Felhermeldung. Was mache ich hier falsch??

PHP:

         Option Explicit

Private Sub UserForm_initialize()
With ComboBox1
.AddItem "Grundstücksfläche"
.AddItem "Gebäudefläche"
.AddItem "Tiefgaragenfläche"
.AddItem "Strassenfläche"
.Style = fmStyleDropDownList
End With
End Sub


Private Sub CommandButton1_Click()

Dim objShp As Object


If ComboBox1.ListIndex > -1 Then
If OptionButton1 Then
Set objShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, Range("F3").Left, Range("F3").Top, 50, 50)
Else
Set objShp = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Range("F3").Left, Range("F3").Top)
With objShp
.AddNodes msoSegmentLine, msoEditingAuto, Range("F3").Left + 50, Range("F3").Top
.AddNodes msoSegmentLine, msoEditingAuto, Range("F3").Left + 75, Range("F3").Top + 35
.AddNodes msoSegmentLine, msoEditingAuto, Range("F3").Left + 50, Range("F3").Top + 70
.AddNodes msoSegmentLine, msoEditingAuto, Range("F3").Left, Range("F3").Top + 35
.AddNodes msoSegmentLine, msoEditingAuto, Range("F3").Left, Range("F3").Top
Set objShp = .ConvertToShape
End With
End If

With objShp
.Fill.ForeColor.RGB = Choose(ComboBox1.ListIndex + 1, 52377, 10079487, 52479, 12632256)
.Line.ForeColor.RGB = vbBlack
.Line.Weight = 0.25
.Name = ComboBox1.Text & Format(Now, "_ddMMyyhhmmss")
.OnAction = "Tabelle1.calculateArea"
End With
Unload Me
Else
MsgBox "Keine Grundstücksart gewählt!", vbExclamation, "Hinweis"
End If



Dim Shp As Shape
Dim lngPoints As Long
Dim dblFactor As Double
Dim vntName As Variant, vntRet As Variant, vntResult(1 To 7, 1 To 1) As Variant

On Error GoTo ErrExit

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

vntName = Array("Grundstücksfläche", "Gebäudefläche", "Tiefgaragenfläche", "Strassenfläche")

dblFactor = Application.CentimetersToPoints(1)

Range("O3:O9") = ""

For Each Shp In Me.Shapes
vntRet = Application.Match(Left(Shp.Name, InStr(1, Shp.Name & "_", "_") - 1), vntName, 0)
If IsNumeric(vntRet) Then
Range("A1:C100") = ""
With Shp
If .Type = msoFreeform Then
For lngPoints = 1 To .Nodes.Count
Cells(lngPoints + 1, 1) = lngPoints
Cells(lngPoints + 1, 2) = .Nodes.Item(lngPoints).Points(1, 1) / dblFactor
Cells(lngPoints + 1, 3) = .Nodes.Item(lngPoints).Points(1, 2) / dblFactor
Next
If Cells(lngPoints, 2) <> Cells(2, 2) And Cells(lngPoints, 3) <> Cells(2, 3) Then
lngPoints = lngPoints + 1
Cells(lngPoints, 1) = lngPoints - 1
Cells(lngPoints, 2) = Cells(2, 2)
Cells(lngPoints, 3) = Cells(2, 3)
End If
ElseIf .Type = msoShapeRectangle Then
Cells(2, 1) = 1: Cells(2, 2) = .Left / dblFactor: Cells(2, 3) = .Top / dblFactor
Cells(3, 1) = 2: Cells(3, 2) = (.Left + .Width) / dblFactor: Cells(3, 3) = .Top / dblFactor
Cells(4, 1) = 3: Cells(4, 2) = (.Left + .Width) / dblFactor: Cells(4, 3) = (.Top + .Height) / dblFactor
Cells(5, 1) = 4: Cells(5, 2) = .Left / dblFactor: Cells(5, 3) = (.Top + .Height) / dblFactor
Cells(6, 1) = 5: Cells(6, 2) = .Left / dblFactor: Cells(6, 3) = .Top / dblFactor
lngPoints = 6
End If
End With
If lngPoints > 0 Then
Cells(1, 1).FormulaArray = "=SUM((C2:C" & lngPoints - 1 & "+C3:C" & _
lngPoints & ")*(B2:B" & lngPoints - 1 & "-B3:B" & lngPoints & ")/2)"
vntResult((vntRet - 1) * 2 + 1, 1) = vntResult((vntRet - 1) * 2 + 1, 1) + Abs(Cells(1, 1).Value)
End If
End If
Next
Range("O3:O9") = vntResult
Range("A1:C100") = ""

ErrExit:

With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'calculateArea'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Modul - Tabelle1"
.Clear
End If
End With

On Error GoTo 0

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

End Sub


 

Hallo Robert,

du kannst nicht einfach Code-Teile x-beliebig herumkopieren.





« Gruß Sepp »

 

Hallo Josef

Ich danke die wiedermal für deine Hilfe.
Funktioniert echt super und ich habe jetzt verstanden, was ich im Code falsch gemacht habe.

Danke! *Smilie

Gruss,
Robert

 

Hallo Josef

Eine Frage noch bzgl. des Löschvorgangs von Shapes.

Wenn ich ein Shape lösche, sollte mir die Flächenangabe automatisch aktualisiert werden.

Ich habe dies mir folgenden Code versucht aber ohne Erfolg:

PHP:

         Private Sub Worksheet_Change(ByVal Target As Range)

If ActiveSheet.Shapes("Grundstücksfläche").Delete Then
Range("L15").Delete
End If

If ActiveSheet.Shapes("Gebäudefläche").Delete Then
Range("L17").Delete
End If

If ActiveSheet.Shapes("Tiefgaragenfläche").Delete Then
Range("L19").Delete
End If

If ActiveSheet.Shapes("Strassenfläche").Delete Then
Range("L21").Delete
End If
End Sub


 

Hallo Robert,

"Was mache ich denn falsch?"

Alles, das Löschen eines Shapes löst kein Ereignis aus und deine If-Abfrage ist nonsense.




« Gruß Sepp »

 

Hallo Josef

Gibt es hier keine Möglichkeiten einen Art "automatisierten Update nach Delete" zu machen, wenn Flächen gelöscht werden? *rolleyes.gif*

Gruss,
Robert

 

Hallo Robert,

das müsste man über eine Timer lösen, der in regelmäßigen Abständen die Shapes auf dem Blatt zählt und eine entsprechende Aktion ausführt.

Nochmals meine Frage: Wozu das ganze Gemurkse? Excel ist kein Grafikprogramm!




« Gruß Sepp »

 

Hallo Josef

Dein Vorschlag es mit dem Timer zu lösen klingt ja sehr spannend.
So etwas habe ich noch nie gehört. Wie geht man den hier vor?

Ich habe in meinem Excel eine Rentabilitätskalkulation für Immobilienentwicklungsprojekte erstellt. Diese basiert auf simple Flächensimulation, die ich nun mit deiner Hilfe im Excel mit Shapes machen kann. Da ich die erstellten Flächen mit meiner Kalkulation verknüpft habe, verändert sich die Rentabilität sobald ich die Flächen verändere. Es funktioniert mittlerweile sehr gut.

Jedoch ist es etwas störend, wenn ich die Shapes lösche und die Flächenbeträge erhalten bleiben.

Hättest du evtl. noch Lust mir bei diesem Problem zu helfen?*rolleyes.gif*
Meine VBA-Kenntnisse sind leider begrenzt.
Würde mich sehr freuen.

Gruß,
Robert

 

Hallo Robert,

nichts für ungut, aber du hast doch schon Probleme bei den einfachsten VBA Befehlen, ich glaube ein Timer auf API-Basis ist mindestens fünf Nummern zu hoch für dich, da schmiert die nämlich schon beim kleinsten Fehler das ganze Excel ab.

Deswegen sagte ich ja bereits "Auftragsprogrammierung"




« Gruß Sepp »

 

Hallo Josef

Ich verstehe.*wink.gif* Ist OK.

Könntest du mir zumindest ein Tip geben, wie ich in die Formel Width und Hight einbauen kann so, dass mir mit der jeweiligen Flächenberechnung in die Spalte Q und R auch die Breite und die Länge angezeigt werden.

Damit würdest du mir schon sehr weiterhelfen.

Gruss,
Robert

 

Hallo Robert,

in welcher "Formel"?




« Gruß Sepp »

 

... sorry!

In dieser Formel:

PHP:

         Sub calculateArea()
Dim Shp As Shape
Dim lngPoints As Long
Dim dblFactor As Double
Dim vntName As Variant, vntRet As Variant, vntResult(1 To 7, 1 To 1) As Variant

On Error GoTo ErrExit

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

vntName = Array("Grundstücksfläche", "Gebäudefläche", "Tiefgaragenfläche", "Strassenfläche")

dblFactor = Application.CentimetersToPoints(1)

Range("O3:O9") = ""

For Each Shp In Me.Shapes
vntRet = Application.Match(Left(Shp.Name, InStr(1, Shp.Name & "_", "_") - 1), vntName, 0)
If IsNumeric(vntRet) Then
Range("A1:C100") = ""
With Shp
If .Type = msoFreeform Then
For lngPoints = 1 To .Nodes.Count
Cells(lngPoints + 1, 1) = lngPoints
Cells(lngPoints + 1, 2) = .Nodes.Item(lngPoints).Points(1, 1) / dblFactor
Cells(lngPoints + 1, 3) = .Nodes.Item(lngPoints).Points(1, 2) / dblFactor
Next
If Cells(lngPoints, 2) <> Cells(2, 2) And Cells(lngPoints, 3) <> Cells(2, 3) Then
lngPoints = lngPoints + 1
Cells(lngPoints, 1) = lngPoints - 1
Cells(lngPoints, 2) = Cells(2, 2)
Cells(lngPoints, 3) = Cells(2, 3)
End If
ElseIf .Type = msoShapeRectangle Then
Cells(2, 1) = 1: Cells(2, 2) = .Left / dblFactor: Cells(2, 3) = .Top / dblFactor
Cells(3, 1) = 2: Cells(3, 2) = (.Left + .Width) / dblFactor: Cells(3, 3) = .Top / dblFactor
Cells(4, 1) = 3: Cells(4, 2) = (.Left + .Width) / dblFactor: Cells(4, 3) = (.Top + .Height) / dblFactor
Cells(5, 1) = 4: Cells(5, 2) = .Left / dblFactor: Cells(5, 3) = (.Top + .Height) / dblFactor
Cells(6, 1) = 5: Cells(6, 2) = .Left / dblFactor: Cells(6, 3) = .Top / dblFactor
lngPoints = 6
End If
End With
If lngPoints > 0 Then
Cells(1, 1).FormulaArray = "=SUM((C2:C" & lngPoints - 1 & "+C3:C" & _
lngPoints & ")*(B2:B" & lngPoints - 1 & "-B3:B" & lngPoints & ")/2)"
vntResult((vntRet - 1) * 2 + 1, 1) = vntResult((vntRet - 1) * 2 + 1, 1) + Abs(Cells(1, 1).Value)
End If
End If
Next
Range("O3:O9") = vntResult
Range("A1:C100") = ""

ErrExit:

With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'calculateArea'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Modul - Tabelle1"
.Clear
End If
End With

On Error GoTo 0

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub