VBA: .Shapes.AddShape funktioniert nicht
03.04.2020 07:50:19
Axel
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