Excel Makro Schleife

Hallo Andreas,
Sorry, ich habe erst zu spät gemerkt, dass ich mich gestern nicht unter meinem üblichen Konto angemeldet hatte. Deshalb habe ich es heute mit meinem Konto mit der dazugehörigen E-Mail-Adresse nochmals versucht.
Aber hier geht es auch.
Vielen Dank für die gestrige Antwort.
In Spalte B und N und Z stehen Dateinamen ohne .JPG und der Pfad in AT1?-> genau
Es funktioniert nicht. Das Foto sieht kleiner aus als vorher (altes Marko) und folgende Fehlermeldung erscheint:


Nach Bestätigung wird die Fehlermeldung für das 2. Foto angezeigt und nach dieser Bestätigung ein Laufzeitfehler '1004'.
Debuggen:



Danach werden die ersten beiden Fotos eingefügt.
Vielen Dank.

Bitte keine Fragen doppelt mit verschiedenen Profilen stellen, das verstößt gegen die Verhaltensregeln.
https://answers.microsoft.com/de-de...schleife/7dfc45b8-ebdf-4580-a3d0-4dc49c86341a
Microsoft Community – Verhaltensregeln
Rückfragen bitte in dem anderen Thread.
Andreas.

Zip mal die Exceldatei und ein paar Bilder zusammen, lad das ZIP auf einen Filehoster und poste den Download-Link hier, dann kuck ich mal.
Andreas.

In Spalte B und N und Z stehen Dateinamen ohne .JPG und der Pfad in AT1?
Andreas.
Option Explicit

Sub FotosEinfügen()
Dim fotopfad As String, dateiname As String
Dim Where As Range, R As Range
Dim Sh As Shape

'Globaler Pfad
fotopfad = Range("AT1").Value
If Right(fotopfad, 1) <> "\" Then fotopfad = fotopfad & "\"

'Alle Zellen Spalte B
Set Where = Range("B4", Range("B" & Rows.Count).End(xlUp))
'Fotos einfügen
GoSub FotoEinfügen
'Dito.
Set Where = Range("N4", Range("N" & Rows.Count).End(xlUp))
GoSub FotoEinfügen
Set Where = Range("Z4", Range("Z" & Rows.Count).End(xlUp))
GoSub FotoEinfügen
'Fertig
Exit Sub

FotoEinfügen:
'Wenn ein Fehler auftritt Schleife verlassen
On Error GoTo ErrorHandler
'Alle Zellen durchlaufen
For Each R In Where
'Kompletten Pfad generieren
dateiname = fotopfad & R & ".jpg"
'Foto einfügen
Set Sh = InsertPicture(dateiname, R)
'Ewtwas schieben
With Sh
.IncrementTop 3
.IncrementLeft 19
End With
Next
ErrorHandler:
On Error GoTo 0
Return
End Sub

Private Function InsertPicture(ByVal FName As String, ByVal Where As Range, _
Optional ByVal LinkToFile As Boolean = False, _
Optional ByVal SaveWithDocument As Boolean = True, _
Optional ByVal LockAspectRatio As Boolean = True) As Shape
'Inserts the picture file FName as link or permanently into Where
Dim S As Shape, SaveScreenUpdating, SaveCursor
SaveCursor = Application.Cursor
SaveScreenUpdating = Application.ScreenUpdating
Application.Cursor = xlWait
Application.ScreenUpdating = False
With Where
'Insert in original size
Set S = Where.Parent.Shapes.AddPicture( _
FName, LinkToFile, SaveWithDocument, .Left, .Top, -1, -1)
'Keep the proportions?
S.LockAspectRatio = LockAspectRatio
'Scale it to fit the cell
S.Width = .Width
If S.Height > .Height Or Not LockAspectRatio Then S.Height = .Height
'Move it to the middle of the cells
If S.Width < Where.Width Then S.Left = Where.Left + (Where.Width - S.Width) / 2
If S.Height < Where.Height Then S.Top = Where.Top + (Where.Height - S.Height) / 2
End With
Set InsertPicture = S
Application.Cursor = SaveCursor
Application.ScreenUpdating = SaveScreenUpdating
End Function

Hallo Roland,

entweder werkelt ein Makro oder du, aber nicht beide gleichzeitig. Und wenn du ein Makro schreibst, dass von 8:00 bis 22:00 eine Schleife ausführt, arbeitest du nichts mehr in der Mappe.

Du kannst doch in der Tabelle2, in die deine Abfrage gemacht wird, in den Bereich der Daten einen Rechtsklick machen => Datenbereichseigenschaften und dort wählen, dass diese Tabelle alle 5 Minuten aktualisiert wird. Dazu brauchst du doch kein Makro.

Claus