Makro erzeugt Sprechblasen und soll aber Punkte setzen :: Office-Hilfe.com - Wir lösen Ihre Probleme mit Microsoft Office

Einloggen, um private Nachrichten zu lesen

Downloads

Makro erzeugt Sprechblasen und soll aber Punkte setzen

Office-Hilfe.com - Wir lösen Ihre Probleme mit Microsoft Office Foren-Übersicht » Microsoft Excel Hilfe

Autor

Nachricht

Finley77
Besserwisser

Anmeldedatum: 18.11.2006
Beiträge: 65
Wohnort: Heidelberg

Verfasst am: 09.09.2008, 08:52

Hallo liebe Leute,

ich habe eine Vorlage mit einem Makro, das Postleitzahlen in geographische Punkte auf einer Deutschlandkarte übersetzen kann. Nur sind diese Punkte leider Sprechblasen, in denen der Ortsname steht. Am besten wäre es doch, wenn die graphische Darstellung mit Punkten (kleine bis große, je nach Anzahl der dargestellten Quellwerte) erfolgen würde. Ich habe nämlich 1300 Einträge (bisher Sprechblasen)...

Kann mir einer die Sprechblasen zu Punkten machen?

Hier ist das Makro:

Private Sub cmdDaten_Click()
Dim varPos As Variant
Dim strBlatt As String
Dim strObjekt As String
Dim strBeschriftung As String
Dim strKarte As String
Dim strDummy As String
Dim objZiel As Shape
Dim XTopLeft As Double
Dim YTopLeft As Double
Dim XBottomRight As Double
Dim YBottomRight As Double
Dim x As Double
Dim y As Double
Dim i As Long
Dim colVorhanden As New Collection
Dim objShape As Shape
Dim wsVorher As Worksheet
XTopLeft = Me.Range("E2") 'Längengrad Links oben
YTopLeft = Me.Range("D2") 'Breitengrad Links oben
XBottomRight = Me.Range("F2") 'Längengrad Rechts unten
YBottomRight = Me.Range("C2") 'Breitengrad Rechts unten
strBlatt = Me.Range("A2") 'Kartenblattname
strKarte = Me.Range("B2") 'Name der Karte

colVorhanden.Add strKarte, strKarte
Set wsVorher = ActiveSheet
Worksheets(strBlatt).Activate
On Error Resume Next

For i = 6 To 1325
If Me.Cells(i, 1) <> "" Then
x = Me.Cells(i, 2) 'Längengrad des Objekts
y = Me.Cells(i, 3) 'Breitengrad des Objekts
strBeschriftung = Me.Cells(i, 5) 'Beschriftung des Objekts

'Eindeutigen Objektnamen generieren
strObjekt = "X" & Format(x, "0.000") & Format(y, "0.000")

'Position berechnen
varPos = PositionBerechnen( _
XTopLeft, YTopLeft, _
XBottomRight, YBottomRight, _
strBlatt, strKarte, _
x, y)

If IsArray(varPos) Then

Err.Clear
Set objZiel = Worksheets(strBlatt).Shapes(strObjekt)
If Err.Number <> 0 Then
'Shape erzeugen
Set objZiel = Worksheets(strBlatt).Shapes.AddShape( _
msoShapeRoundedRectangularCallout, _
0, 0, _
100, 20)
'Namen für Shape vergeben
objZiel.Name = strObjekt
End If

colVorhanden.Add strObjekt, strObjekt
With objZiel

'Objekt beschriften
.TextFrame.Characters.Text = strBeschriftung
'Verschieben und Pfeil auf Ziel setzen
.Left = varPos(1) + .Width / 2
.Top = varPos(2) - .Height * 2
.DrawingObject.ShapeRange.Adjustments.Item(1) = -0.5
.DrawingObject.ShapeRange.Adjustments.Item(2) = 2
End With
End If
End If
Next

For Each objShape In Worksheets(strBlatt).Shapes
'Nicht benötigte Shapes löschen
Err.Clear
strDummy = colVorhanden(objShape.Name)
If Err.Number <> 0 Then objShape.Delete
Next
wsVorher.Activate
End Sub

Vielen Dank im Voraus und viele Grüße
Fin

schatzi
Moderator

Anmeldedatum: 09.12.2006
Beiträge: 5748

Verfasst am: 09.09.2008, 12:43

Hallo!

Die Art des Objektes wird hier definiert:
Set objZiel = Worksheets(strBlatt).Shapes.AddShape( _
msoShapeRoundedRectangularCallout, _
0, 0, _
100, 20)

Was es sonst noch für Shapes gibt, kannst du in der VBA-Hilfe unter "AutoShapeType" nachlesen.

_________________

Viele Grüße vom Schatzi
------------------------
Ich bin nur noch sporadisch erreichbar!
Bitte hofft nicht auf eine schnelle Beantwortung einer Rückfrage meinerseits!
Jeder andere Helfer darf Rückfragen gerne übernehmen und hilft sicher gerne weiter!

Finley77
Besserwisser

Anmeldedatum: 18.11.2006
Beiträge: 65
Wohnort: Heidelberg

Verfasst am: 09.09.2008, 12:55

Vielen Dank, ich habe es inzwischen mit einem RightArrow ersetzt, bin aber immer noch nicht zufrieden. Ballungszentren werden nicht so richtig deutlich... Ich schau mal weiter...

Office-Hilfe.com - Wir lösen Ihre Probleme mit Microsoft Office Foren-Übersicht » Microsoft Excel Hilfe

Thema		Autor	Forum	Antworten	Verfasst am
Ähnliche Beiträge
	Anpassung von Diagrammen per Makro?	gassi83	Microsoft Excel Hilfe	0	19.12.2008, 12:31
	Makro Rückgängig	floater	Microsoft Excel Hilfe	3	12.12.2008, 01:00
	Hilfe zu VBA, habe aber keinen Plan	enzo	Microsoft Excel Hilfe	0	11.12.2008, 13:32
	Word 2007 Makro bringt Fehlermedlung ...	Ted	Microsoft Word Hilfe	0	21.11.2008, 21:31
	WQord 2007 fehler beim Makro (kopilie...	Ted	Microsoft Word Hilfe	0	21.11.2008, 07:40

Gehe zu:

Du kannst keine Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum nicht antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
Du kannst Dateien in diesem Forum posten
Du kannst Dateien in diesem Forum herunterladen

Powered by phpBB © 2001, 2002 phpBB Group :: FI Theme :: Alle Zeiten sind GMT + 1 Stunde
Deutsche Übersetzung von phpBB.de