Bilder in Abfall-Kalender

Hey All,
Ich habe mir einen dynamischen Kalender erstellt, der als Abfall-Kalender fungieren soll.
Ich möchte die Müll-Tonnen immer am Donnerstag anzeigen lassen. ( Bilder )
Das habe ich einigermaßen mit Makro hinbekommen, aber wenn ich das Jahr ändere, sind die Bilder dann auch auf einen anderen Tag.
Außerdem ist es immer eine andere Abfall-Tonne am Anfang vom Jahr. ( Schwarz, blau, gelb ) . jpg
Ich habe verschiedene Dinge versucht, mit DoubleClick, CommandButton, Worksheet_SelectionChange
leider bekomme ich es nicht hin auch nach vielem suchen im Netz.
Des weiteren muss ich auch jede Tonne einzeln löschen wenn ich die Tonnen ändern muss.
Der Pfad liegt "H:\Excel-Tonnen\" (".jpg")
Am liebsten wäre mir eine DoubleClick - Funktion ( Donnerstag ) wo ich die Tonnen dann raussuchen kann die sich dann in die Zelle kopiert.
Oder über einer Listbox ansprechen die die Tonnen beinhaltet und bei Auswahl in die Zelle kopiert.
Ich denke mal das es nicht so einfach ist, aber vielleicht ist ja jemand hier der mir helfen könnte, würde.
Ich danke schon mal allen im Voraus
https://www.herber.de/bbs/user/154638.xlsm
Lg
Dieter

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Dieter,
der folgende Code "Sub Schwarz" setzt für jeden Donnerstag des Jahres das Symbol für die Schwarze Tonne,
Der weiter unten folgende Code "SUB loeschPics" entfernt alle Shapes im Kalenderbereich.
Beide Codes stellst Du in ein eigenes Modul und startest sie auch dort.
Dann musst Du noch Lösungen für die Gelbe Tonne, die Blaue Tonne und den Sperrmüll erarbeiten


Option Explicit
Sub Schwarz()
Dim sp As Long
Dim ze As Long
With Sheets("Kalender")
.Shapes.Range(Array("Schwarz")).Select
Selection.Copy
For sp = 3 To 24 Step 4
For ze = 3 To 67
On Error Resume Next
If IsDate(.Cells(ze, sp - 2)) Then
If Weekday(.Cells(ze, sp - 2), 2) = 4 Then
.Cells(ze, sp).Select
.Paste
Application.Wait (Time + (TimeValue("00:00:01")))
Selection.ShapeRange.ScaleHeight 0.5, msoTrue
Selection.ShapeRange.IncrementLeft 3.75
Selection.ShapeRange.IncementTop -2.25
Selection.Name = "ShCell" & .Cells(ze, sp - 2).Address '!!! wichtig fürs Löschen
.Cells(ze, sp - 2).Select
End If
End If
Next
Next
End With
End Sub
Sub loeschPics()
Dim shpShape As Object
For Each shpShape In ActiveSheet.Shapes
If shpShape.Name Like "ShCell*" Then
shpShape.Delete
End If
Next
End Sub

Gruß
Jochen

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bilder in Abfall-Kalender

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread