![]() |
Betrifft: Logo einfügen --> Hajo
von: Tom
Geschrieben am: 04.11.2012 19:35:48
Hallo Hajo,
hallo liebes Forum,
anscheined kann ich auf meinen Beitrag nicht mehr antworten, da er zu lange ruhte (war ohne Netz ...)
Hier der Beitrag vom 27.10.12
https://www.herber.de/forum/archiv/1284to1288/t1284075.htm#1284107
Anbei mal die Testdatei und 6 Logos (Team 1-6).
https://www.herber.de/bbs/user/82480.zip
Die Logos sollen jeweils in Spalte E, G, Y, AA und AS automatisch eingefügt werden (ab Zeile 3). Es wäre schön, wenn mir jemand den Lösungsweg erklären könnte.
Danke vorab.
Gruß
TOM
![]() ![]() |
Betrifft: AW: Logo einfügen
von: Hajo_Zi
Geschrieben am: 04.11.2012 19:39:24
Hallo Tom,
nur welche?
![]() ![]() |
Betrifft: AW: Logo einfügen
von: Tom
Geschrieben am: 04.11.2012 19:47:23
Hallo Hajo,
z.B. Logo von Team1 in E3, G7, E12 usw. (immer vor den Namen)
Gruß
TOM
![]() ![]() |
Betrifft: AW: Logo einfügen
von: Hajo_Zi
Geschrieben am: 04.11.2012 19:50:17
Hallo Tom,
ich sehe mich nicht in der Lage Dir zu Helfen. Du gibts die Inforamtionen nur Stückchenweise. Das sind jetzt 3 Zellen aber ich glaube in der Tabelle sollen einige hundert eingefügt werden. Ich wünsche Dir dann noch viel Erfolg.
Ich bin raus.
Gruß Hajo
![]() ![]() |
Betrifft: AW: Logo einfügen
von: Tom
Geschrieben am: 04.11.2012 19:59:03
Hi Hajo,
sorry, aber ich dachte der Lösungsweg ist einfacher.
Es wäre mir schon geholfen, wenn Du mir nur bei Team1 helfen könntest.
Das betrifft dann das Logo "1" und Team1 in der Tabelle für folgende Zellen:
E3, E12, G7, G16, AS3
Wenn ich mal einen Lösungsansatz hätte, komme ich evtl. mit den anderen selbst klar.
Wäre Dir sehr dankbar!
Gruß
TOM
![]() ![]() |
Betrifft: AW: Logo einfügen
von: Tom
Geschrieben am: 04.11.2012 20:22:24
Ich habe versucht, den Code von Deiner Beispieldatei auf Deiner Website abzuändern, aber ich vermute hierfür reichen meine VBA-Kenntnisse nicht aus. Aber ich denke, dass ist genau der Lösungsansatz:
Option Explicit
' Konstante für Ablagepfad Bilder
' Const StPfad As String = "K:\Allgemein\text-Dateien\" ' Bildordner wird nicht benötigt
Dim Loi As Long ' Schleifenvariable
Dim StTabelle As String ' Tabellenname
Dim StAdresse As String ' Zelladresse
Private Sub Workbook_Open() '************************************************** '* H. Ziplies * '* 27.01.10 * '* erstellt von HajoZiplies@web.de * '* http://Hajo-Excel.de/ * '************************************************** ' Array mit Adressen und eingetragen Werte füllen ' da Bilder schon eingefügt wurden müssen die nicht eingefügt werden StArray = Array(Array("", "", "", "", "", ""), Array("Spielplan!E3:E79", "Spielplan!G3:g79", _ "Spielplan!Y3:y79", "Spielplan!AA3:AA79", Spielplan!AS3:AS79")) For Loi = 0 To UBound(StArray(0), 1) ' Tabelle abtrennen StTabelle = Application.WorksheetFunction.Substitute(Left(StArray(1)(Loi), InStr( _ StArray(1)(Loi), "!") - 1), "'", "") StAdresse = Application.WorksheetFunction.Substitute(Mid(StArray(1)(Loi), InStr(StArray( _ 1)(Loi), "!") + 1), "'", "") If Worksheets(StTabelle).Range(StAdresse) <> "" And InStr(Worksheets(StTabelle).Range( _ StAdresse), ".") > 0 Then StArray(0)(Loi) = Range(StArray(1)(Loi)) Next Loi End Sub
Private Sub Workbook_SheetCalculate(ByVal Sh As Object) '************************************************** '* H. Ziplies * '* 27.01.10 * '* erstellt von HajoZiplies@web.de * '* http://Hajo-Excel.de/ * '************************************************** Dim StBild As String ' Variable für Bildname Application.ScreenUpdating = False ' _ Bildschimaktualisierung aus For Loi = 0 To UBound(StArray(0), 1) StTabelle = Application.WorksheetFunction.Substitute(Left(StArray(1)(Loi), InStr( _ StArray(1)(Loi), "!") - 1), "'", "") StAdresse = Application.WorksheetFunction.Substitute(Mid(StArray(1)(Loi), InStr(StArray( _ 1)(Loi), "!") + 1), "'", "") If Worksheets(StTabelle).Range(StAdresse) <> "" And InStr(Worksheets(StTabelle).Range( _ StAdresse), ".") > 0 _ And Worksheets(StTabelle).Range(StAdresse) <> StArray(0)(Loi) Then 'neues Bild On Error Resume Next ' falls Bild nicht _ vorhanden Worksheets(StTabelle).Shapes("Bild " & StArray(1)(Loi)).Delete On Error GoTo 0 ' Fehlerbehandlung zurü _ ck StBild = ThisWorkbook.Path & "\" & Worksheets(StTabelle).Range(StAdresse) If Dir(StBild) = "" Then ' Prüfen ob Datei _ vorhanden Application.EnableEvents = False ' Reaktion auf Eingabe _ abschalten Worksheets(StTabelle).Range(StAdresse).Offset(0, 1) = "kein Bild" StArray(0)(Loi) = "" ' Bildnamen löschen Application.EnableEvents = True ' Reaktion auf Eingabe _ einschhalten Else ' einfügen ohne select von Bert Körn ' Ausdruck.AddPicture(FileName, Verknüpfung, in Mappe speichern, ' Pos. Links, Pos. Oben, Breite, Höhe) ' von Klausimausi64 Bildname ' erstes Offset Pos. Links 0 Zeilen und eine Spalte nach rechts ' zweites Offset Pos. Oben 0 Zeilen tiefer und 0 Spalten nach rechts With Worksheets(StTabelle).Shapes.AddPicture(StBild, True, True, Worksheets( _ StTabelle).Range(StAdresse).Offset(0, 2).Left, _ Worksheets(StTabelle).Range(StAdresse).Offset(0, 0).Top, 100, 100) sngHoehe = .Height ' Bildhöhe an Variable ü _ bergeben Hinweis von Uwe (:o) .OnAction = "Bild_BeiKlick" ' Makro im Modul _ BeiKlick .Name = "Bild " & StArray(1)(Loi) ' Bildname festlegen End With ' ******** StArray(0)(Loi) = Worksheets(StTabelle).Range(StAdresse) ' neues Bild in _ Array End If ElseIf Worksheets(StTabelle).Range(StAdresse) = "" Then On Error Resume Next ' falls Bild nicht _ vorhanden Worksheets(StTabelle).Shapes("Bild " & StArray(1)(Loi)).Delete On Error GoTo 0 ' Fehlerbehandlung zurü _ ck StArray(0)(Loi) = "" ' Bildnamen löschen End If Next Loi Application.ScreenUpdating = True ' _ Bildschimaktualisierung ein End Sub
![]() |