Frage zu Grafik

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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)

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.

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

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.

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

Beliebteste Forumthreads (12 Monate)

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread