Office: Runden Bereich in VBA definieren

Flipsi · 10. Oktober 2016

Hallo zusammen,

ich schreibe im Rahmen meiner Abschlussarbeit ein Statikprogramm um Stahl-Verbundstützen zu bemessen. Das ist ein doppel-T Stahlprofil mit ausbetonierter Kammer und eingelegten Bewehrungseisen.

Die Bemessung mit VBA klappt auch super, allerdings muss ich den Querschnitt auch grafisch Darstellen.
Hierzu definiere ich in Abhängigkeit von den gegebenen Abmessungen verschiedene Range-Objekte, die dann bestimmte Werte für die unterschiedlichen Materialien in die einzelnen Zellen des Bereichs schreiben (z.B. "Ac" für die Betonfläche). Mit einer bedingten Formatieren färbe ich jetzt alle Zellen abhängig vom Inhalt und bekomme so den Querschnitt dargestellt.

Set rngBeton = Range(Cells(int_ZS, int_SS), Cells(int_ZS + dbl_HProfil - 1, int_SS + dbl_BProfil - 1))

For Each rng_Zelle In rngBeton
rng_Zelle.Value = "Ac"
Next rng_Zelle

Mein Problem ist jetzt, dass ich nicht so recht weiß, wie ich einen runden Bereich erzeugen kann um die Bewehrungsstäbe darzustellen. Vielleicht hat ja einer von euch eine gute Idee um das Problem zu lösen.

Bitte nicht die Sinnhaftigkeit der Darstellungsart anzweifeln, ich muss das so machen und finde es selber etwas umständlich *frown.gif*

:)

R J · 12. Oktober 2016

Hi Flipsi,

ich frage mich gerade, was ein 'runder' Bereich sein könnte....*wink.gif*

so was?

Code:

Sub runderBereich()
Dim rundBer As Range, res%, var
Set rundBer = Union(Range("B1"), Range("A2:C2"), Range("A3:C3"), Range("A4:C4"), Range("B5"))

rundBer.Interior.Color = 65000
rundBer.Value = rundBer.Value + 1
res = WorksheetFunction.Sum(rundBer)
Cells(7, 2) = " Ergebnis aller gelben Zellen = " & res

''oder: wenn Du alle einzeln durchlaufen willst:
'For Each var In rundBer
'var.Interior.Color = 255
var,Value = var.Value + 1
'Next

'res = WorksheetFunction.Sum(rundBer)
'Cells(8, 2) = " Ergebnis aller roten Zellen = " & res
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Flipsi · 12. Oktober 2016

Ok, runder Bereich war etwas blöd ausgedrückt *biggrin.gif*

Ich hab die Zellen im Arbeitsblatt in dem der Querschnitt dargestellt wird auf 1x1 Pixel gestellt, nun versuche ich irgendwie die Zellen rund (kreisförmig) mit einem Wert auszufüllen, soll dann nachher nach schöner 8-bit Grafik ausschauen.

Mein Problem ist, dass sich Anzahl, Lage und Durchmesser der Bewehrungsstäbe ändern und ich ehrlich gesagt nicht so wirklich weiß wie ich das anstellen soll.
Trapezförmig bekomme ich hin, bei rund scheitere ich aber.

im Prinzip sowas hier, nur ohne Yin und Yang:

Wobei ich mich auch egrade nach anderen Möglichkeiten am umschauen bin um den Querschnitt darzustellen, ich finde das hier doch etwas umständlich und es dauert auch ziemlich lange bis die ganzen Schleifen durchgelaufen sind :/

xlph · 12. Oktober 2016

Verwende Formen (Shapes)

R J · 12. Oktober 2016

...naja, das scheint doch so zu passen, wie oben beschrieben. Die Zelladressen des "runden" Bereiches mit Union zu einem Bereich 'setten'.

Nochmal das Beispiel:
Code:

Dim rundBer As Range, res%, var
Set rundBer = Union(Range("B1"), Range("A2:C2"), Range("A3:C3"), Range("A4:C4"), Range("B5"))
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

und diese Scheife hier:
Code:

For Each rng_Zelle In rngBeton
rng_Zelle.Value = "Ac"
Next rng_Zelle
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

kannst Du Dir sparen. Weise dem gesamten Bereich den gemeinsamen Wert auf einen Rutsch zu:

Code:

rundBer.Value = "AC"
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Allerdings tust Du mir beim Bereich definieren für das Ying Yang Beispiel herzlich leid....*wink.gif*

Es sei denn, Du nutzt eine Schleife und prüfst einen quadratischen Bereich, innerhalb dessen der runde Bereich liegt, ob er farbig ist. Wenn ja, dann diese Zelle zum runden Bereich hinzufügen.
Bsp.:
Code:

Sub runderBereich()
Dim rb As Range, adr$, qb As Range, var
Set qb = Range("A1:C6")

For Each var In qb
If var.Interior.Color 16777215 Then adr = adr & var.Address & ","
Next
adr = VBA.Left(adr, VBA.Len(adr) - 1)
Set rb = Range(adr)
Debug.Print rb.Address
set rb = nothing
set qb = nothing
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

R J · 12. Oktober 2016

...ach ja, um Runde Bereiche zu markieren ginge das:

Code:

Sub q()
Querschnitt 10
End Sub

Sub Querschnitt(Einheit As Integer)
Dim start%, spalten%, zeilen%, plus%
start = Einheit / 2
Cells.Clear
For zeilen = 1 To Einheit - 1
For spalten = start To Einheit
Cells(zeilen, start + plus).Interior.Color = 255
Cells(zeilen, start - plus).Interior.Color = 255
Next spalten
plus = IIf(zeilen >= start, plus + 1, plus - 1)
Next zeilen
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Hat allerdings einen kleinen Schönheitsfehler, nur gerade Zahlen werden ordentlich markiert.

Flipsi · 12. Oktober 2016

Danke schonmal für die Antworten*Smilie Ich werde mal versuchen es anzuwenden!

Wäre es nicht einfacher das ganze in einem Diagramm darzustellen? Also einzelne Punkte zu bestimmen und durch Linien zu verbinden?
Die Sache mit den Zellen und der bedingten Formatierung zur Darstellung hat doch noch so einige Schwachstellen *eek.gif*

R J · 12. Oktober 2016

...wenn es Dir weder um einen Bereich noch um dessen Formatierung geht, sondern ganz einfach nur darum, einen Kreis mit einem bestimmten Durchmesser darstellen zu wollen, dann geht das ja noch viel einfacher.

Füge eine Form (Shape -> Ellipse) auf das Blatt ein. Benenne die Form (heißt wahrscheinlich Ellipse 1) um. Nenne sie Kreis.

Füge diesen Code in das Modul dieser Tabelle ein:

Code:

Sub q()
ZeichneKreis 7 '7 soll der Durchmesser sein...
End Sub

Sub ZeichneKreis(einheit As Double)

Dim Hoehe#, Breite#
Hoehe = einheit * 28.34
Breite = einheit * 28.34

ActiveSheet.Shapes("Kreis").Select
Selection.ShapeRange.Height = Hoehe
Selection.ShapeRange.Width = Breite
Cells(1, 1).Select

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

EarlFred · 12. Oktober 2016

Hallo,

Bitte nicht die Sinnhaftigkeit der Darstellungsart anzweifeln, ich muss das so machen und finde es selber etwas umständlich
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

wenn die einzig zulässige Variante das "Kästchenmalen" ist, dann probier mal dies:

Code:

Option Explicit

Sub test()
funcKreismaler 15, 15, 20, RGB(0, 0, 255), 1.05
End Sub

Function funcKreismaler(ByRef x As Long, ByRef y As Long, ByRef r As Long, col As Long, Optional ByRef rund As Double = 1)
Dim xTemp As Long, yTemp As Long
Dim rUnion As Range

For xTemp = -r To r
For yTemp = -r To r
If (xTemp ^ 2 + yTemp ^ 2) ^ (1 / 2) 0) And (xTemp + x > 0) Then
If Not rUnion Is Nothing Then
Set rUnion = Union(rUnion, Cells(yTemp + y, xTemp + x))
Else
Set rUnion = Cells(yTemp + y, xTemp + x)
End If
End If
End If
Next yTemp
Next xTemp
If Not rUnion Is Nothing Then
rUnion.Interior.Color = col
funcKreismaler = True
End If
Set rUnion = Nothing
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Grüße
EarlFred

Flipsi · 13. Oktober 2016

Danke EarlFred, genau sowas habe ich gesucht!
Da wäre ich allerdings in 100 Jahren nicht drauf gekommen *rolleyes.gif*

Mal schauen, ob ich das ganze jetzt so hinbekomme :/

wick62 · 13. Oktober 2016

Hallo,

Wäre es nicht einfacher das ganze in einem Diagramm darzustellen?
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

das must Du für Dich entscheiden, es wurden ja mehre Lösungsvorschläge aufgezeichnet.

Hier eine Variante als Diagramm.

Gruß Hans

Flipsi · 19. Oktober 2016

Ich hab mich jetzt für die Variante mit der Darstellung durch Zellen entschieden, bisher scheint auch alles halbwegs zu funktionieren *rolleyes.gif*

Danke an Alle für die Hilfe *Smilie

Office: Runden Bereich in VBA definieren

Runden Bereich in VBA definieren

Runden Bereich in VBA definieren

Runden Bereich in VBA definieren

Runden Bereich in VBA definieren

Runden Bereich in VBA definieren - Similar Threads - Runden Bereich VBA

aktuelles Alter aus Geburtsdatum auslesen und runde Geburtstage markieren

Datum/Uhrzeit runden in PowerQuery

Runden bei Zeiten

immer auf die nächsten 0,50€ aufrunden

Problem mit Runden (round)

#Wert!

Mathematisches Runden (Banker's Rounding) ohne VBA