Wappen automatisch in Spielplan einfügen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_Calculate() on error resume next ActiveSheet.Shapes("Wappen").Delete on error goto DFB ActiveSheet.Pictures.Insert(left(activeworkbook.FullName, instrrev(activeworkbook.FullName,"\")) _ & "Wappen\" & Range("C2").Value & ".jpg").Select Selection.Name = "Wappen 1" 'Anpassung Größe und Position Selection.ShapeRange.IncrementLeft 303 Selection.ShapeRange.ScaleWidth 1.22, msoFalse, msoScaleFromTopLeft Selection.ShapeRange.ScaleHeight 1.22, msoFalse, msoScaleFromTopLeft Exit sub DFB: 'DFB-Wappen wird geladen, wenn kein Wappen gefunden wurde ActiveSheet.Pictures.Insert(left(activeworkbook.FullName, instrrev(activeworkbook.FullName,"\")) _ & "Wappen\DFB.jpg").Select Selection.Name = "Wappen 1" 'Anpassung Größe und Position Selection.ShapeRange.IncrementLeft 303 Selection.ShapeRange.ScaleWidth 1.22, msoFalse, msoScaleFromTopLeft Selection.ShapeRange.ScaleHeight 1.22, msoFalse, msoScaleFromTopLeft End Sub

function GraphicfileInZelleEinfuegen(lngZeile As Long, lngSpalte As Long, strDatei as string, _ Optional strPfad As String = "") Dim strPfad As String Dim lngZeile As Long Dim wksTabelle As Worksheet Dim shpNeu As Object lngSpalte = 3 ' =C Set wksTabelle = ActiveWorkbook.Worksheets("Ergebniseingabe") If strPath = "" Then strPfad = ActiveWorkbook.Path End If strDatei = "Fahne_D.png" If Right(strPfad, 1) "\" Then strPfad = strPfad & "\" Set shpNeu = wksTabelle.Pictures.Insert(strPfad & strDatei) 'evtl noch Abfrage ob Datei ü _ berhaupt vorhanden shpNeu.Top = wksTabelle.Rows(lngZeile).Top shpNeu.Height = wksTabelle.Rows(lngZeile).Height shpNeu.Left = wksTabelle.Columns(lngSpalte).Left shpNeu.Width = wksTabelle.Columns(lngSpalte).Width * 5 'hier könntest Du auch über den _ Range abfragen wieviel verbundene Zellen betroffen sind und es so variabel machen End Sub

Hallo Stefan,
ich geh jetzt einfach davon aus, dass Du jpg verwendest und das die Bilddatei so heisst wie der Verein (identische Schreibweise)
Das ganze läuft in einer selbstgeschriebenen Funktion, der Aufruf erfolgt so, wie Du es gewohnt bist, als Funktionsaufruf in den Zellen:
Wenn du das noch woanders brauchst, musst du nur aufpassen, dass du die richtige Quelle anziehst (Zelle wo der Name steht).
Falls Du keine jpg verwendest, dann musst Du das beim Aufruf in den Zellen korrigieren (einfach mal eine Zelle mit logo anklicken und schauen was dann oben unter fx zu sehen ist. da kannst Du dann die Dateiendung anpassen.
Damit solltest Du hoffentlich klarkommen
https://www.herber.de/bbs/user/94278.xlsm
Gruß
yummi

Hallo Stefan,
ich versuch mal die Fragen zu klären ;-)
Wenn Du das Wappen in der Zelle mal löscht (dann kommst Du besser an die Zelle ran ;-)
dann siehst Du, dass in jeder Zelle, in der ein Wappen zu sehen ist eine Formel steht. Das beduetet, wenn du dein Wappen woanders haben willst, dann musst Du dort eben die Formel eintragen. Die Formel unterscheidet sich in den einzelnen Zellen nur an einer Stelle, dass ist die Zelle die den Namen des Wappens, welches angezeigt werden soll bestimmt (muss nicht direkt daneben sein, kann sogar auf einem anderen Tabellenblattsein, einfach beim eingeben der Formel, nachdem der Cursor an der Stelle für die Zelle steht, auf die gewünschte Zelle klicken und gut ist)
Fazit: Du kannst dein Wappen anzeigen lassen wo immer du willst, einfach
=GraphicfileInZelleEinfuegen(ZEILE();SPALTE();D73&".jpg") eingeben (für D73 natürlich deine gewünschte zelle, wo der Name steht
Das Wappen erscheint in der Zelle, in der Du die Formel eingibst.
Die einzige Bedingung, die das Bild hat, es muss ein jpg sein. Falls Du png nehmen willst, musst du den Teil ".jpg" durch ".png" ersetzen. Andere Dateiendungen gehen nicht.
Das Wappen passt sich dann der Größe der Zelle an, wobei je nachdem ob zuerst die Höhe oder die Breite der Zelle erreicht wird, dann schluss ist (es wird also nicht aus einem quadratischen Wappen ein rechteckiges)
Die Bilddatei muss im selben Pfad liegen, wie die excel Datei.
Wenn Du das Ganze mal in eienr anderen Datei verwenden willst, dann musst Du das was in dem Modul1 (im VBA Editor) ist mitnehmen. Modul2 kannst du löschen, das wird nicht benötigt, hab vergessen sauber zu machen)
Ich hoffe, es wird klarer, wie Du damit was anfangen kannst.
Axo noch eine Kleinigkeit:
Du kannst die Funktion auch so aufrufen
=GraphicfileInZelleEinfuegen(ZEILE();SPALTE();D73&".jpg", "deinbilderverzeichnis")
dann läd er die Wappen aus dem von dir gewählten Verzeichnis (sollte jedenfalls klappen, hab ich aber nicht getestet ;-)
Viel Spass beim Spielen und auspobieren
yummi
PS: Wenn Du noch Fragen hast, vlt hab ich ja noch ein parr Antworten

Function GraphicfileInZelleEinfuegen(lngZeile As Long, lngSpalte As Long, strDatei As String, _ Optional strPfad As String = "") Dim shpNeu As Object Dim iFaktor As Integer Dim wksTabelle As Worksheet Dim rng As Range Set wksTabelle = ActiveSheet iFaktor = wksTabelle.Cells(lngZeile, lngSpalte).MergeArea.Columns.Count If strPfad = "" Then strPfad = ActiveWorkbook.Path End If If Right(strPfad, 1) "\" Then strPfad = strPfad & "\" If Dir(strPfad & strDatei) "" Then 'alte Wappen löschen On Error Resume Next wksTabelle.Shapes.Range(Array("Grafik" & lngSpalte & lngZeile)).Delete Set rng = wksTabelle.Range(wksTabelle.Cells(lngZeile, lngSpalte), wksTabelle.Cells( _ lngZeile, lngSpalte)) Set shpNeu = wksTabelle.Pictures.Insert(strPfad & strDatei) 'evtl noch Abfrage ob _ Datei überhaupt vorhanden shpNeu.Top = wksTabelle.Rows(lngZeile).Top With shpNeu With .ShapeRange .LockAspectRatio = msoTrue If .Height > rng.Height Then .Height = rng.Height If .Width > rng.Width * iFaktor Then .Width = rng.Width * iFaktor End With .Height = wksTabelle.Rows(lngZeile).Height .Left = wksTabelle.Columns(lngSpalte).Left .Name = "Grafik" & lngSpalte & lngZeile .Top = rng.Top + (rng.Height - .Height) / 2 .Left = rng.Left + (rng.Width * iFaktor - .Width) / 2 End With Else MsgBox strPfad & strDatei & " nicht vorhanden" End If Set wksTabelle = Nothing End Function

Function GraphicfileInZelleEinfuegen(lngZeile As Long, lngSpalte As Long, strDatei As String, _ Optional strPfad As String = "") Dim shpNeu As Object Dim iFaktor As Integer Dim wksTabelle As Worksheet Dim rng As Range Set wksTabelle = ActiveSheet iFaktor = wksTabelle.Cells(lngZeile, lngSpalte).MergeArea.Columns.Count If strPfad = "" Then strPfad = ActiveWorkbook.Path End If If Right(strPfad, 1) "\" Then strPfad = strPfad & "\" If Dir(strPfad & strDatei) "" Then 'alte Wappen löschen On Error Resume Next wksTabelle.Shapes.Range(Array("Grafik" & lngSpalte & lngZeile)).Delete Set rng = wksTabelle.Range(wksTabelle.Cells(lngZeile, lngSpalte), wksTabelle.Cells( _ lngZeile, lngSpalte)) Set shpNeu = wksTabelle.Pictures.Insert(strPfad & strDatei) 'evtl noch Abfrage ob _ Datei überhaupt vorhanden shpNeu.Top = wksTabelle.Rows(lngZeile).Top With shpNeu With .ShapeRange .LockAspectRatio = msoTrue If .Height > rng.Height Then .Height = rng.Height If .Width > rng.Width * iFaktor Then .Width = rng.Width * iFaktor End With '.Height = wksTabelle.Rows(lngZeile).Height '.Left = wksTabelle.Columns(lngSpalte).Left .Name = "Grafik" & lngSpalte & lngZeile .Top = rng.Top + (rng.Height - .Height) / 2 .Left = rng.Left + (rng.Width * iFaktor - .Width) / 2 End With Else MsgBox strPfad & strDatei & " nicht vorhanden" End If Set wksTabelle = Nothing End Function

Beliebteste Forumthreads (12 Monate)

Wappen automatisch in Spielplan einfügen

29 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

29
Beiträge zum Forumthread

Beiträge zu diesem Forumthread