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

VBA: .Shapes.AddShape funktioniert nicht

VBA: .Shapes.AddShape funktioniert nicht
03.04.2020 07:50:19
Axel
Hallo zusammen,
ich habe aus einem Buch einen Code übertragen, der in einen Fehler läuft.
Ich hab den Code in ein Modul eingefügt.
Gleich am Anfang bei Set ws1 = Worksheet(1) kommt heute ein Fehler "

Sub oder Funktion nicht definiert".
Das kam gestern komischerweise nicht, da gab es weiter unten eine Fehlermeldung bei .Shapes. _
AddShape(msoShapeOval,
Ich hatte im Netz nach einer Lösung geschaut und eine ausprobiert bei ws1, die hat aber nicht  _
funktioniert. Da ich heute gar nicht mehr erst so weit komme, kann ich die Fehlermeldung leider nicht mehr schreiben.
Ich hoffe, jemand mit mehr Sachverstand kann die Unstimmigkeit im Code identifizieren und mir  _
weiterhelfen.
Vielen Dank vorab!
Axel

Sub ZweiTabellenblätterVergleichen()
Dim wb As Workbook
Dim strOriginalFile As String, strCopyFile As String
Dim ws1 As Worksheet, ws2 As Worksheet
Dim objws1Row As Object, obwjs1Col As Object
Dim objws2Row As Object, objws2Col As Object
Dim intMaxRow As Integer, intMaxCol As Integer
Dim intCol As Integer, intRow As Integer
Dim strCompWS1 As String, strCompWS2 As String
Dim shp As Shape 'Das habe ich als Lösungsansatz ausprobiert
'Referenzierung
Set ws1 = Worksheet(1) 'hier kommt schon der Fehler wegen 

Sub und Funktion
Set ws2 = Worksheet(2)
Set objws1Row = ws1.UsedRange.Rows
Set objws1Col = ws1.UsedRange.Columns
Set objws2Row = ws2.UsedRange.Rows
Set objws2Col = ws2.UsedRange.Columns
'Bildschirmaktualisierung und Warnungen ausschalten
With Application
.ScreenUpdating = False
.DislayAlerts = Fals
End With
'Pfad und Dateiangaben von Original und Kopie
strOriginalFile = ThisWorkbook.FullName
strCopyFile = "ErrorReport.xlsx"
'Eine Kopie der Mappe erstellen, damit nichts überschrieben wird
'Pfad muss ggf angepasst werden
ThisWorkbook.Save
ThisWorkbook.SaveAs "C:\" & strCopyFile
'Maximale Zeilenzahl ermitteln
If objws1Row.Count > objws2.Row.Count Then
intMaxRow = objws1Row.Count
Else
intMaxRow = objws2Row.Count
'Maximale Spaltenzahl ermitteln
If objws1Col.Count > objws2.Col.Count Then
intMaxCol = objws1Col.Count
Else
intMaxCol = objws2Col.Count
End If
'Jede Zelle der beiden Tabellenblätter vergleichen
For intCol = 1 To intMaxCol
For intRow = 1 To intMaxRow
strCompWS1 = ws1.Cells(intRow, intCol)
strCompWS2 = ws2.Cells(intRow, intCol)
If strCompWS1  strCompWS2 Then
'Unterschiedliche Einträge rot umranden
With ws1
Set shp = .Shapes.AddShape(msoShapeOval, _ 'Das habe ich als Lösungsansatz  _
ausprobiert
.Cells(intRow, intCol).Left, _
.Cells(intRow, intCol).Top, _
.Cells(intRow, intCol).Width. _
.Cells(intRow, intCol).Heigth)
.Fill.Visible = msoFalse
.Line.ForeColor.SchemeColor = 10
End With
'Kommentar einfügen
.Cells(intRow, intCol).AddComment strCompWS2
End With
With ws2
With.Shapes.AddShape(msoShapeOval, _ 'So steht es original im Buch, klappt  _
aber nicht
.Cells(intRow, intCol).Left, _
.Cells(intRow, intCol).Top, _
.Cells(intRow, intCol).Width. _
.Cells(intRow, intCol).Heigth)
.Fill.Visible = msoFalse
.Line.ForeColor.SchemeColor = 10
End With
.Fill.Visible = msoFalse
.Line.ForeColor.SchemeColor = 10
End With
'Kommentar einfügen
.Cells(intRow, intCol).AddComment strCompWS1
End With
End If
Next intRow
Next intCol
'Originaldatei wieder öffnen
Workbooks.Open strOriginalFile
'Kopie aktivieren
Workbooks(strCopyFile).Activate
'Bildschirmaktualisierung und Warnungen einschalten
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
'Objekte wieder freigeben
Set ws1 = Nothing
Set ws2 = Nothing
Set objws1Row = Nothing
Set objws1Col = Nothing
Set objws2Row = Nothing
Set objws2Col = Nothing
End Sub

14
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA: .Shapes.AddShape funktioniert nicht
03.04.2020 08:21:22
Regina
Moin,
da hast Du beim übertragen nicht aufgepasst, es heißt Worksheets (mit "s")
Gruß Regina
AW: VBA: .Shapes.AddShape funktioniert nicht
03.04.2020 08:28:35
Axel
Hallo Regina,
da hast Du natürlich völlig recht! Hab's geändert und jetzt komm ich auch wieder zum eigentlichen Fehler an der Stelle
With ws1
Set shp = .Shapes.AddShape(msoShapeOval, _
beziehungsweise
With ws1
With.Shapes.AddShape(msoShapeOval, _
Beides läuft in einen Syntaxfehler. Da hab ich gerade noch mal nachgeschlagen, richtig übertragen habe ich.
Woran liegt das denn?
Danke und Gruß
Axel
AW: VBA: .Shapes.AddShape funktioniert nicht
03.04.2020 08:54:25
EtoPHG
Hallo Axel,
Sollen wir jetzt dein ganzes Buch korrekturlesen?
Du hast nicht richtig abgeschrieben, bzw. selbst am Code rumgebastelt, ohne diesen zu verstehen!
Diese Konstrukt
 With ws2
With.Shapes.AddShape(msoShapeOval, _

ist völliger Unsinn und falls es so im Buch steht, wirf es weg! Zwischen With und .Shapes muss eine Leerstelle sein. Dein Versuch innerhalb des With Konstrukts ein zweites Aufzuziehen scheitert, weil dann die .Cells-Referenzierungen sich auf das With-Shape, statt auf das Worksheet beziehen und shapes haben nun mal keine Zellen!
Gruess Hansueli
Anzeige
AW: VBA: .Shapes.AddShape funktioniert nicht
03.04.2020 10:32:43
Axel
Vielen Dank für die bisherige fachliche Unterstützung.
Ich hab den Code noch mal Zeile für Zeile gecheckt, trotzdem bleibt er hängen bei der Formatierung der Unterschiede ( With .Shapes.AddShape...).
Fehlermeldung:
Laufzeitfehler 438: Objekt unterstützt diese Eigenschaft oder Methode nicht.
Nach meinem Verständnis ist ws1 als workshheets (Set ws1 = Worksheets(1)) deklariert und das Objekt worksheets hat auch die Eigenschaft Shapes, also sollte das doch funktionieren.
Wäre toll, wenn jemand eine Idee hat, woran es liegt.
Hier noch mal der ganze Code schreibfehlerkorrigiert:
Sub ZweiTabellenblätterVergleichen()
Dim wb As Workbook
Dim strOriginalFile As String, strCopyFile As String
Dim ws1 As Worksheet, ws2 As Worksheet
Dim objws1Row As Object, obwjs1Col As Object
Dim objws2Row As Object, objws2Col As Object
Dim intMaxRow As Integer, intMaxCol As Integer
Dim intCol As Integer, intRow As Integer
Dim strCompWS1 As String, strCompWS2 As String
'Referenzierung
Set ws1 = Worksheets(1)
Set ws2 = Worksheets(2)
Set objws1Row = ws1.UsedRange.Rows
Set objws1Col = ws1.UsedRange.Columns
Set objws2Row = ws2.UsedRange.Rows
Set objws2Col = ws2.UsedRange.Columns
'Bildschirmaktualisierung und Warnungen ausschalten
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'Maximale Zeilenzahl ermitteln
If objws1Row.Count > objws2Row.Count Then
intMaxRow = objws1Row.Count
Else
intMaxRow = objws2Row.Count
End If
'Maximale Spaltenzahl ermitteln
If objws1Col.Count > objws2Col.Count Then
intMaxCol = objws1Col.Count
Else
intMaxCol = objws2Col.Count
End If
'Jede Zelle der beiden Tabellenblätter vergleichen
For intCol = 1 To intMaxCol
For intRow = 1 To intMaxRow
strCompWS1 = ws1.Cells(intRow, intCol)
strCompWS2 = ws2.Cells(intRow, intCol)
If strCompWS1  strCompWS2 Then
'Unterschiedliche Einträge rot umranden
With ws1
With .Shapes.AddShape(msoShapeOval, _
.Cells(intRow, intCol).Left, _
.Cells(intRow, intCol).Top, _
.Cells(intRow, intCol).Width, _
.Cells(intRow, intCol).Heigth)
.Fill.Visible = msoFalse
.Line.ForeColor.SchemeColor = 10
End With
'Kommentar einfügen
.Cells(intRow, intCol).AddComment strCompWS2
End With
With ws2
With .Shapes.AddShape(msoShapeOval, _
.Cells(intRow, intCol).Left, _
.Cells(intRow, intCol).Top, _
.Cells(intRow, intCol).Width, _
.Cells(intRow, intCol).Heigth)
.Fill.Visible = msoFalse
.Line.ForeColor.SchemeColor = 10
End With
'Kommentar einfügen
.Cells(intRow, intCol).AddComment strCompWS1
End With
End If
Next intRow
Next intCol
'Bildschirmaktualisierung und Warnungen einschalten
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
'Objekte wieder freigeben
Set ws1 = Nothing
Set ws2 = Nothing
Set objws1Row = Nothing
Set objws1Col = Nothing
Set objws2Row = Nothing
Set objws2Col = Nothing
End Sub
Danke vorab für eure Hilfsbereitschaft
Axel
Anzeige
Nachtrag zu Shapes
03.04.2020 11:05:09
Axel
Nach meinem Verständnis funktionieren geschachtelte With-Anweisungen so, dass die innere With-Anweisung sich auf das innere Objekt bezieht, in dem Fall auf Shapes.
Der Syntax von .Shapes.AddShape(msoShapeOval, folgen 4 Werte, die die Form beschreiben. Diese 4 Werte werden hier als Zellbezüge dargestellt.
Ist das so richtig und wenn niucht, wie müsste der Code sonst aussehen?
Vielen Dank!
Was für eine XL-Version hast Du ?
03.04.2020 11:11:04
EtoPHG
Hallo,
Ja deine Annahme bezgl. With-Konstrukten ist richtig.
Was für eine XL Version hast du genau?
Gruess Hansueli
AW: Was für eine XL-Version hast Du ?
03.04.2020 11:36:18
Axel

Sub ExcelVersion()
Debug.Print Application.Version
End Sub
14.0
Anzeige
Probier mal RGB anstelle von SchemeColor
03.04.2020 11:53:24
SchemeColor
Hallo,
.Line.ForeColor.RGB = RGB(255, 0, 0)

Gruess Hansueli
AW: Probier mal RGB anstelle von SchemeColor
03.04.2020 12:01:48
SchemeColor
Hansueli,
so weit kompiliert der Code nicht, weil er bereits an der Stelle davor
With .Shapes.AddShape(msoShapeOval, _
.Cells(intRow, intCol).Left, _
.Cells(intRow, intCol).Top, _
.Cells(intRow, intCol).Width, _
.Cells(intRow, intCol).Heigth)
hängen bleibt. Der ganze Block wird gelb markiert.
Dann kann ich auch nicht weiterhelfen...
03.04.2020 13:45:00
EtoPHG
Axel,
Ich setz den Thread auf offen.
Vielleicht kann jemand mit der veralteten XL2010 anhand einer Beispielmappe von Dir mehr rausfinden.
Gruess Hansueli
Anzeige
AW: Dann kann ich auch nicht weiterhelfen...
03.04.2020 14:00:00
Axel
OK, Danke anyway für Deine Hilfe!
Bleib gesund.
AW: Dann kann ich auch nicht weiterhelfen...
03.04.2020 14:12:37
Mullit
Hallo,
och menno Hansueli nu mach mal mein xl2010 nich schlecht..;-) aber ne, liegt denk ich eher hier dran:
.Heigth <> .Height
Gruß, Mullit
oops. Danke Herr Archäologe ;-)
03.04.2020 15:01:13
EtoPHG

Nach 3maliger Überprüfung:Schreibfehler!! (owT)
03.04.2020 15:08:08
EtoPHG

166 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige