Bilder einfügen laut Pfad

Hallo!
Ich nutze seit langem diesen VBA Code um aus einer Spalte N (hier steht der Pfad) Bilder in die Spalte O einzufügen. Das funktioniert auch super, aber leider nur "28 Bilder auf einen Schlag". Nun muss ich aber 5000 Bilder einfügen und so ist das etwas unpraktisch. Gibt es da eine Möglichkeit um mehr Bilder in einem Rutsch einzufügen?


Private Sub Worksheet_Change(ByVal Target As Range)
'* H. Ziplies                                     *
'* 24.11.07                                       *
'* erstellt von Hajo.Ziplies@web.de               *
'* http://Hajo-Excel.de/
Dim StBild As String                                                ' Variable für Bildname
Dim InI As Integer                                                  ' Schleifenvariable
Dim RaBereich As Range                                              ' Bereich der  _
Wirksamtkeit
Dim RaZelle As Range                                                ' Zelle die in der  _
Schleife bearbeitet wird
'   Bereich der Wirksamkeit
Set RaBereich = Range("n2:n200000")
Set RaBereich = Intersect(RaBereich, Range(Target.Address))         ' nur die Zellen Prüfen  _
_
_
die im überwachten Bereich liegen
If Not RaBereich Is Nothing Then                                    'falls nicht gefunden    _
_
_
wird sub verlassen
For Each RaZelle In RaBereich                                   ' Schleife über alle  _
veränderten Zellen im überwachten Bereich
Application.EnableEvents = False                            ' Reaktion auf Eingabe   _
_
_
abschalten
'           Text "kein Bild" löschen
RaZelle.Offset(0, 1) = ""
Application.EnableEvents = True                             ' Reaktion auf Eingabe   _
_
_
einschalten
StBild = "Bild " & RaZelle.Address(False, False)            ' Bildname erstellen
'           altes Bild löschen von jinx
For InI = ActiveSheet.Shapes.Count To 1 Step -1
If ActiveSheet.Shapes(InI).Name = StBild Then
ActiveSheet.Shapes(InI).Delete
Exit For
End If
Next
If RaZelle.Value  "" Then                                 ' es wurde ein  _
Dateiname eingegeben
'               Bildname
StBild = StPfad & Format(RaZelle.Value) & ""
If Dir(StBild) = "" Then                                ' Prüfen ob Datei  _
vorhanden
Application.EnableEvents = False                    ' Reaktion auf Eingabe   _
_
_
abschalten
Target.Offset(0, 1) = "kein Bild"
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 ActiveSheet.Shapes.AddPicture(StBild, True, True, RaZelle.Offset(0, 1). _
_
_
Left + 1, _
RaZelle.Offset(0, 0).Top + 1, Width:=ActiveCell.Width - 2, Height:=  _
_
_
ActiveCell.Height - 2)
.OnAction = "Bild_BeiKlick"         ' Makro im Modul BeiKlick
.Name = "Bild " & RaZelle.Address(False, False) ' Bildname festlegen
.Placement = xlMoveAndSize ' von Zell-Position und -Größe abhängig
End With
End If
End If
Next RaZelle
End If
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Thomas,
ich habe das Makro soweit wie möglich aufgeräumt. Teste mal:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    Const ON_ACTION As String = "Bild_BeiKlick"
    Const NO_PICTURE As String = "kein Bild"

    Dim strPath As String
    Dim strName As String
    Dim objShape As Shape
    Dim objRange As Range
    Dim objCell As Range

    Set objRange = Intersect(Target, Range("N2:N200000"))

    If Not objRange Is Nothing Then

        With Application
            .EnableEvents = False
            .ScreenUpdating = False
        End With

        For Each objCell In objRange

            objCell.Offset(0, 1).Value = Empty

            strName = "Bild " & objCell.Address(False, False)

            For Each objShape In Shapes
                If objShape.Name = strName Then
                    objShape.Delete
                    Exit For
                End If
            Next

            If Not IsEmpty(objCell.Value) Or Not objCell.EntireRow.Hidden Then

                strPath = objCell.Text

                If Dir$(strPath) = vbNullString Then

                    objCell.Offset(0, 1).Value = NO_PICTURE

                Else

                    Set objShape = Shapes.AddPicture(strPath, msoFalse, msoTrue, _
                        objCell.Offset(0, 1).Left + 1, objCell.Top + 1, _
                        objCell.Width - 2, objCell.Height - 2)

                    With objShape
                        .OnAction = ON_ACTION
                        .Name = strName
                        .Placement = xlMoveAndSize
                    End With
                End If
            End If
        Next

        Set objRange = Nothing
        Set objShape = Nothing

        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With

    End If
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread