VBA: Prüfen welche Grafiken noch nicht gelöscht

Computer: Software & Programmierung Visual Basic
#1

Hi VBA Cracks,
ich habe via VBA am Bildschirm 10x10 Grafiken/Kreise (Shapes) erstellt, insgesamt also 100 Kreise am Bildschirm.
Jeder Kreis hat auch einen eigenen Namen (mit shape.name).
Der erste Kreis links oben hat dabei den Namen „01 01“ der 2. Kreis in der Reihe „01 02“ und der letzte Kreis, rechts unten „10 10“.
Somit hab ich eine art x-y Bezug zu jedem Kreis.

Jetzt werden willkürlich Kreise gelöscht, ganz normal über Kreis anklicken und „Entf“ Taste drücken.

Ich möchte nun anschlißend via VBA ZÜGIG rausfinden welche Kreise sind noch am Bildschirm? Ich denke dabei an ein 2-dimensionales Array wo mal eine „1“ reingeschrieben wird (quasi an der x-y-Pos.) falls der Kreis vorhanden ist oder eine „0“ falls Kreis fehlt.

ICH HABE HIER MEHRMALS GEHÖRT DIE „SELECT FUNKTION“ SOLL MAN STETS VERMEIDEN WEGN LAHMER GESCHWINDIGKEIT… ICH KONMME HIER ABER NUR MIT EINEM SELECT TEST WEITER?

Danke für jegliche Information.
Lombe

#2

ICH HABE HIER MEHRMALS GEHÖRT DIE „SELECT FUNKTION“ SOLL MAN
STETS VERMEIDEN WEGN LAHMER GESCHWINDIGKEIT… ICH KONMME HIER
ABER NUR MIT EINEM SELECT TEST WEITER?

Hallo Lombe,

anstatt hier rumzuschreien zeige mal lieber den Code damit man sieht warum du da Select benutzen mußt, ich sehe da erstmal keinerlei Grund dafür.

Und daß man Select/Active zu 99% nicht braucht hörste in allen Excelforen denn es ist so.
Nicht nur weil das den Code langsam macht, es macht den Code sehr bedeutend schlechter lesbar.

Gruß
Reinhard

#3

Hallo Reinhard,
hier sind beide codes (Kreise verlegen am Bildschirm
und der 2. code mit dem Test welche Kreise noch vorhanden sind.

Der 1.code geht soweit.
Im 2. Code mach ich alles falsch… benutzte Select und
auch noch ein „Goto“ mit Sprungmarke der nicht funktioniert.
Zudem wird die Sprungmarke immer angesprungen…

(Select und Goto = schlechten Ruf)

Option Explicit

Private Sub Kreise_setzen()
Dim X As Byte
Dim Y As Byte
Dim x_abstand As Integer
Dim y_abstand As Integer

x_abstand = 300 'Bezugspunkt am Bildschirm für den 1. Kreis links oben
y_abstand = 150 'Bezugspunkt am Bildschirm für den 1. Kreis links oben

Worksheets(3).Shapes(„Grafik2“).Copy '„Grafik2“ = Das ist der Kreis der als Vorlage in der 3. Mappe (Worksheets3) befindet

For Y = 1 To 10

For X = 1 To 10
Worksheets(1).Paste
Selection.Top = y_abstand
Selection.Left = x_abstand
Selection.Name = Right(Y + 100, 2) & " " & Right(100 + X, 2) 'Hier wird dem Kreis einem Namen vergeben als (x-y Position)

x_abstand = x_abstand + 80 '80 Punkte versetzt (nach rechts) wird der nächste Kreis gesetzt
Next X

y_abstand = y_abstand + 80 '80 Punkte versetzt (nach unten) wird der nächste Kreis gesetzt
x_abstand = 300 'damit beginnt der 1. Kreis der nächsten Zeile wieder linksbündig

Next Y

End Sub

Private Sub Teste_welche_Kreise_noch_vorhanden()
Dim X As Byte
Dim Y As Byte
Dim Matrix(1 To 10, 1 To 10) As Byte
Dim Kreis_Name As String

For Y = 1 To 10

For X = 1 To 10
Kreis_Name = Right(Y + 100, 2) & " " & Right(100 + X, 2)
ActiveSheet.Shapes(Kreis_Name).Select 'Hier wird versucht den Kreis zu selektieren, falls keiner da ist soll in die Matrix eine „0“
On Error GoTo Fehler:

Matrix(X, Y) = 1

Fehler:
Matrix(X, Y) = 0

Next X

Next Y

End Sub

Danke für jegliche Information

#4

hier sind beide codes (Kreise verlegen am Bildschirm
und der 2. code mit dem Test welche Kreise noch vorhanden
sind.

Hallo Lombe,

Option Explicit

Private Sub Kreise\_setzen()
Dim X As Byte, Y As Byte, x\_abstand As Integer, y\_abstand As Integer
x\_abstand = 300 'Bezugspunkt am Bildschirm für den 1. Kreis links oben
y\_abstand = 150 'Bezugspunkt am Bildschirm für den 1. Kreis links oben
'"Grafik2" = Das ist der Kreis der als Vorlage in der 3. Mappe (Worksheets3) befindet
Worksheets(3).Shapes("Grafik2").Copy
For Y = 1 To 10
 For X = 1 To 10
 Worksheets(1).Paste
 Selection.Top = y\_abstand
 Selection.Left = x\_abstand
 'Hier wird dem Kreis einem Namen vergeben als (x-y Position)
 '80 Punkte versetzt (nach rechts) wird der nächste Kreis gesetzt
 Selection.Name = Right(Y + 100, 2) & " " & Right(100 + X, 2)
 x\_abstand = x\_abstand + 80
 Next X
 '80 Punkte versetzt (nach unten) wird der nächste Kreis gesetzt
 y\_abstand = y\_abstand + 80
 'damit beginnt der 1. Kreis der nächsten Zeile wieder linksbündig
 x\_abstand = 300
Next Y
End Sub

Private Sub Teste\_welche\_Kreise\_noch\_vorhanden()
Dim Matrix(1 To 10, 1 To 10) As Byte, Sh As Shape
For Each Sh In Worksheets(1).Shapes
 If Mid(Sh.Name, 3, 1) = " " Then
 Matrix(Split(Sh.Name)(0), Split(Sh.Name)(1)) = 1
 End If
Next Sh
'weiterer Code um Matrix auszuwerten o.ä.
End Sub

Gruß
Reinhard

#5

Hallo.

auch noch ein „Goto“ mit Sprungmarke der nicht funktioniert.
Zudem wird die Sprungmarke immer angesprungen…

Die Anweisung ‚On Error Goto Sprungmarke‘ ist definitiv legitim. Du hast sie nur an der falschen Stelle geschrieben. Diese Anweisung sollte immer am Anfang einer Prozedur stehen, weil immer erst nach dieser Anweisung „auf Fehler reagiert“ wird. Scheinbar möchtest Du aber in Deinem Code mit dem ‚Select‘ absichtlich einen Fehler mit auslösen, aber zu diesem Zeitpunkt würde noch gar nicht auf Fehler reagiert werden.

VG
Carsten

#6

Hallo Reinhard,
danke für die Lösung! Den „Each-Befehl“ hab ich schon öfters hier gesehen, lern ihn aber erst beim nächsten VBA-Aufbaukurs näher kennen, daher.
War klar dass mein Select-GoTo-Code totaler Käse war. Im weiteren Schritt kann ich nun die Matrix super auswerten für weitere Schritte.

Danke nochmal
Gruß Lombe

#7

Hi Carsten,
hab hier von Reinhard bereits
eine einfachere Lösung für mein Problem gefunden,
danke trotzdem

gruß
lombe