Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1072to1076
1072to1076
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Frage zu Grafik

Forumthread: Frage zu Grafik

Frage zu Grafik
16.05.2009 01:54:39
Benedikt
Guten Morgen
Nachfolgender Code, (vielen Dank Beverly) Fügt einzelne Bilder ab der Zeile B6 aneinander und das Perfekt.
Das nächste Makro sollte eine andere Bildserie in Zelle 15 erstellen. Geht auch, aber erst ab dem letzten Bild der Zeile 6. Nötig währe aber ab B15.
Danke für Hilfe und eine kurze Erklärung.
ActiveSheet.Shapes(ActiveSheet.Application.Caller).Copy
With Worksheets("Zeichnung")
.Paste
If .Shapes.Count > 1 Then
.Shapes(.Shapes.Count).Left = .Shapes(.Shapes.Count - 1).Left + .Shapes(.Shapes. _
Count - 1).Width
.Shapes(.Shapes.Count).Top = .Range("B6").Top
Else
.Shapes(1).Left = .Range("B6").Left
.Shapes(1).Top = .Range("B6").Top
End If
End With
Anzeige

16
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Grafik kopieren und anordnen
16.05.2009 08:30:43
doppelt
Hi Benedikt,
probier mal das hier: 

Option Explicit
Sub BildAnfuegen2()
Dim sngT As Single, sngL As Single, ii As Integer
Const strC As String = "D15"     ' anpassen
With Worksheets(2)               ' anpassen
sngT = .Range(strC).Top
sngL = .Range(strC).Left
For ii = 1 To .Shapes.Count
If Abs(.Shapes(ii).Top - sngT)

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
P.S.: Du hättest auch im Thread https://www.herber.de/forum/messages/1075023.html bleiben können -
Zusatzfrage stellen + Häkchen bei "Frage noch offen".

Anzeige
AW: Grafik kopieren und anordnen
16.05.2009 09:55:24
Benedikt
Guten Morgen Erich. Herzlichen Dank für deine Hilfe. So Funzt das eigentlich gar nicht schlecht. Obwohl dieses Zeichnen nicht wirklich Excel scheint, ist die ganze Kalkulation einer Küche damit verbunden.
2 Fragen zu dieser Zeichnerei habe ich noch.
Ich Kopiere ein Objekt (Bild) aus Tabelle 1 nach 2 zb. nach B38. Das Bild sollte oben links in der Zelle einfügen. Mit Selection.ShapeRange.IncrementLeft -26.6 lässt sich die Position einigermassen einstellen aber nur mit x-fachem probieren.
Die zweite Frage scheint schwieriger:
Für eine Küche gibt es Hochschrank, Unterbau und Oberbaumöbel. Alle Bilder der Unterbaumöbel werden mithilfe deines Code ab Zelle B36 jeweils aneinandergereiht. Für die Oberbauten ist der Bezug beginnend Zelle B6. Dies läuft dank Deines Code Perfekt. Jetzt kommt ein Hochschrank welcher sich wieder ab B38 anreiht. Dieser ist in der Höhe aber bis Zelle B6. Beim einlesen des nächsten Oberbau (ab B6) erkennt aber die Grafik nicht, das ein Element aus B38 schon vorhanden ist. Sorry nicht ganz einfach zu erklären und auch nicht Lebenswichtig! Wenn Du eine Lösung siehst währe das Toll, ansonsten einen schönen Tag und vielen Dank.
Anzeige
AW: Frage zu Grafik
16.05.2009 10:16:16
Beverly
Hi Benedikt,
der folgende Code gilt für alle Bilder:

Sub BildAnfuegen()
Dim shShape As Shape
Dim doLinks As Double
Dim arrZeile6()
Dim inZeile6 As Integer
Dim arrZeile15()
Dim inZeile15 As Integer
ActiveSheet.Shapes(ActiveSheet.Application.Caller).Copy
With Worksheets("Zeichnung")
For Each shShape In .Shapes
If shShape.Top = .Range("B6").Top Then
ReDim Preserve arrZeile6(0 To inZeile6)
arrZeile6(inZeile6) = shShape.Left + shShape.Width
inZeile6 = inZeile6 + 1
ElseIf shShape.Top = .Range("D15").Top Then
ReDim Preserve arrZeile15(0 To inZeile15)
arrZeile15(inZeile15) = shShape.Left + shShape.Width
inZeile15 = inZeile15 + 1
End If
Next shShape
.Paste
Select Case ActiveSheet.Shapes(ActiveSheet.Application.Caller).Name
Case "Rectangle 1", "Rectangle 2", "Rectangle 3", "Rectangle 4"
.Shapes(.Shapes.Count).Top = .Range("B6").Top
If .Shapes.Count > 1 Then
.Shapes(.Shapes.Count).Left = Application.WorksheetFunction.Max(arrZeile6()) _
Else
.Shapes(.Shapes.Count).Left = .Range("B6").Left
End If
Case "Oval 5", "Oval 6", "Oval 7", "Oval 8"
.Shapes(.Shapes.Count).Top = .Range("B15").Top
If .Shapes.Count > 1 Then
.Shapes(.Shapes.Count).Left = Application.WorksheetFunction.Max(arrZeile15() _
)
Else
.Shapes(.Shapes.Count).Left = .Range("BD15").Left
End If
End Select
End With
End Sub


Ich habe im Beispiel mal einfach mit Shapes aus der Zeichnen-Symbolleiste gearbeitet - die Namen musst du also durcht deine Bildnamen ersetzen.


Anzeige
AW: Frage zu Grafik - Korrektur
16.05.2009 10:28:11
Beverly
Hi Benedikt,
sorry, da war noch ein Fehler im Code wenn noch kein Bild in der betreffenden Zeile vorhanden war. Jetzt sollte der Code ohne Fehler laufen

Sub BildAnfuegen()
Dim shShape As Shape
Dim doLinks As Double
Dim arrZeile6()
Dim inZeile6 As Integer
Dim arrZeile15()
Dim inZeile15 As Integer
ActiveSheet.Shapes(ActiveSheet.Application.Caller).Copy
With Worksheets("Zeichnung")
For Each shShape In .Shapes
If shShape.Top = .Range("B6").Top Then
ReDim Preserve arrZeile6(0 To inZeile6)
arrZeile6(inZeile6) = shShape.Left + shShape.Width
inZeile6 = inZeile6 + 1
ElseIf shShape.Top = .Range("B15").Top Then
ReDim Preserve arrZeile15(0 To inZeile15)
arrZeile15(inZeile15) = shShape.Left + shShape.Width
inZeile15 = inZeile15 + 1
End If
Next shShape
.Paste
Select Case ActiveSheet.Shapes(ActiveSheet.Application.Caller).Name
Case "Rectangle 1", "Rectangle 2", "Rectangle 3", "Rectangle 4"
.Shapes(.Shapes.Count).Top = .Range("B6").Top
On Error Resume Next
doLinks = Application.WorksheetFunction.Max(arrZeile6())
On Error GoTo 0
If doLinks  0 Then
.Shapes(.Shapes.Count).Left = doLinks
Else
.Shapes(.Shapes.Count).Left = .Range("B6").Left
End If
'               .Shapes(.Shapes.Count).OnAction = ""
Case "Oval 5", "Oval 6", "Oval 7", "Oval 8"
.Shapes(.Shapes.Count).Top = .Range("B15").Top
On Error Resume Next
doLinks = Application.WorksheetFunction.Max(arrZeile15())
On Error GoTo 0
If doLinks  0 Then
.Shapes(.Shapes.Count).Left = Application.WorksheetFunction.Max(arrZeile15() _
)
Else
.Shapes(.Shapes.Count).Left = .Range("B15").Left
End If
'               .Shapes(.Shapes.Count).OnAction = ""
End Select
End With
End Sub


Ich habe auch noch 2 Zeilen (die auskommentiert sind) ergänzt, falls die eingefügten Bilder keine Verknüpfung zum Makro haben sollen.


Anzeige
Vorerst vielen Dank Karin
16.05.2009 10:49:27
Benedikt
Vielen herzlichen Dank Karin. Bis ich jetzt Verstanden und probiert habe geht es noch einen Moment.
Gebe auf jeden Fall ein Feedback.
Einen schönen Samstag und nocheinmal Dankeschön
Erläuterung
16.05.2009 11:12:35
Beverly
Hi Benedikt,
vielleicht hilft dir diese kleine Erläuterung:
zuerst wird in einer Schleife über alle Shapes im Tabellenblatt "Zeichnung" gelaufen und geprüft, ob das Shape in Zeile 6 oder 15 steht. In Abhängigkeit davon wird je ein Array mit der Position Rechts des laufenden Shapes (= shShape.Left + shShape.Width) gefüllt. Nach dem Einfügen des neues Shapes wird der Maximalwert (also die rechte Kante des letzten Shapes) in der betreffenden Zeile dem neuen Shape als linke Position zugewiesen.

Anzeige
Irgendwo klemmts.
16.05.2009 11:47:38
Benedikt
Liebe Karin
Dein Code ist leider für mich als Laiendarsteller nicht Lesbar. Im Moment verteilen sich die Shapes wild auf der Tabelle "Zeichnung"?
Einzige Änderungen:
Case "Bild 8", "Bild 9", "Bild 10", "Bild 10" etc. an den entsprechenden Orten
AW: Irgendwo klemmts.
16.05.2009 15:39:33
Beverly
Hi Benedikt,
den Fehler kann ich leider nicht nachvollziehen da ich deine Arbeitsmappe nicht kenne. In meinem Beispiel wird alles richtig eingefügt.
https://www.herber.de/bbs/user/61875.xls

Anzeige
Läuft wirklich bei Dir, aber
16.05.2009 17:00:47
Benedikt
https://www.herber.de/bbs/user/61876.xls
Hallo Karin
Es läuft wirklich auf deiner Datei. Aber bitte schau auf der Zeichnen Seite das Problem mit der Elypse im Rechteck.
Das ist eigentlich das Hauptproblem.
Wollte die Bildchen einfügen, aber leider sprengt das die 300Kb
Anzeige
AW: Läuft wirklich bei Dir, aber
16.05.2009 21:03:35
Benedikt
https://www.herber.de/bbs/user/61876.xlsHallo Karin
Es läuft wirklich auf deiner Datei. Aber bitte schau auf der Zeichnen Seite das Problem mit der Elypse im Rechteck.
Das ist eigentlich das Hauptproblem.
Wollte die Bildchen einfügen, aber leider sprengt das die 300Kb
Anzeige
AW: Läuft wirklich bei Dir, aber
16.05.2009 21:05:56
Beverly
Hi Benedikt,
natürlich wird das Oval immer in Höhe der Zeile 15 eingefgt, denn das ist im Code ja so festgelegt (nach deiner Vorgabe)
Vielleicht wäre es gut, wenn du mal genau beschreibst, wie du vorgehst. Einen "allround"-Code gibt es wohl nicht, sondern man muss ihn auf die konkreten Gegebenheiten anpaasen.

Anzeige
Danke für deine Geduld
16.05.2009 22:40:40
Benedikt
Hi Karin, sorry für das strapazieren deiner Nerven.
Irgendwie stellte ich mir das zu einfach vor.
Die Rechtecke und Ovale sind Möbelteile. Kunde A möchte von links nach rechts oben Rechtecke und unten Ovale.
(Das läuft ja so bestens, selbst wenn er als letztes noch den Gelben Hochschrank will.
Kunde B möchte aber links mit dem Gelben Hochschrank beginnen und anschliessend oben die Rechtecke und unten die Ovale. Da wir Bezug B6 haben klappt das auch mit weiteren Rechtecken, aber das Oval sollte den Abstand des gelben Hochschrank aucheinhalten.
Und C möchte zuerst oben und unten, Mittig den gelben zweimal und anschliessend wieder oben und unten. Und so weiter. Leider habe ich auch keine "Normkunden, sonder Individuelle Menschen mit Unterschiedlichen Wünschen und Vorstellungen.
Ich verstehe das es keinen Universalcode gibt. Aber ich glaubte, dass das Grosse Rechteck in irgend einer Form einen Bezug bildet, welcher auch in den unteren Zellen seine Gültigkeit hat.
Leider geht das nicht. Ich Danke Dir für die viele Zeit die Du mir geschenkt hast. Solltest Du trotzdem noch eine Mäglichkeit sehen bin ich Dankbar
Anzeige
Picture statt Bild ?
16.05.2009 16:54:58
Erich
Hi Benedikt,
bist du sicher, dass da nicht statt
Case "Bild 8", "Bild 9", ...
vielleicht besser
Case "Picture 8", "Picture 9", ...
stehen sollte?
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
Picture statt Bild ? Genau
16.05.2009 17:29:14
Benedikt
Guten Abend Erich
Genau da war der Hund begraben. Jetzt ist nur noch das eine Problem gemäss Beispielmappe offen.
Vielen Dank für die Hilfe
Anzeige
Grafiken kopieren und anordnen
17.05.2009 13:12:05
Dreifach
Hi Benedikt,
hier mal ein neuer Ansatz, bei dem "Kollisionen" mit schon vorhandenen Shapes vermieden werden (sollen...).
Dafür ist die Funktion da. 

Option Explicit
Sub BildAnfuegenA()
BildAnfuegen "B6"      ' anpassen
End Sub
Sub BildAnfuegenB()
BildAnfuegen "B15"     ' anpassen
End Sub
Sub BildAnfuegen(strC As String)
Dim sngT As Single, sngL As Single, sngH As Single, sngW As Single
Dim ii As Integer, bolOK As Boolean
With ActiveSheet.Shapes(Application.Caller)
sngH = .Height
sngW = .Width
.Copy
End With
With Worksheets("Tabelle3")               ' anpassen
sngT = .Range(strC).Top
sngL = .Range(strC).Left
For ii = 1 To .Shapes.Count
With .Shapes(ii)
If Abs(.Top - sngT) = sngTop + sngHig Or _
sngTop >= shA.Top + shA.Height Or _
shA.Left >= sngLef + sngWid Or _
sngLef >= shA.Left + shA.Width Then
Else
Kolli = True
End If
End Function

Und hier eine Beispielmappe: https://www.herber.de/bbs/user/61882.xls
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Anzeige
Vielen Dank Erich
17.05.2009 21:35:29
Benedikt
Hallo Erich
Vielen herzlichen Dank. Genau das war die Lösung meiner "Vision". Ich hoffe ich darf mich in deinem Leben eimal nützlich machen. Ich erachte das nicht als Selbstverständlich. Danke!!
;

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige