Logo einfügen --> Hajo

Bewerten Sie hier bitte das Excel-Portal

Auftragsprogrammierung: Nehmen Sie hier Kontakt auf

Logo einfügen --> Hajo

Logo einfügen --> Hajo von Tom vom 04.11.2012 19:35:48

AW: Logo einfügen - von Hajo_Zi am 04.11.2012 19:39:24
- AW: Logo einfügen - von Tom am 04.11.2012 19:47:23
  - AW: Logo einfügen - von Hajo_Zi am 04.11.2012 19:50:17
    - AW: Logo einfügen - von Tom am 04.11.2012 19:59:03
      - AW: Logo einfügen - von Tom am 04.11.2012 20:22:24

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?

Grußformel

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