Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1544to1548
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Makro läuft nicht "rund"

Makro läuft nicht "rund"
13.03.2017 17:56:27
Marcel
Hallo,
ich habe u.s.Makro, das mir aus einem Pfad Bilder als Thumbnails in meine Datei zieht. Die Sache ist nur, dass wenn ich einen Filter gesetzt habe und das Makro laufen lasse nach einigen Spalten sich die Thumbnails überlappen und nicht mehr sauber neben den Artikeln stehen. Liegt das am Makro oder kann jemand helfen?
Hier das Makro:
Public Sub prcInsertPicture()
' Legt das Dateiverzeichnis der Artikelbilder fest
Const strPath = "\\PFAD\"
' Definiert die Variablen Zeile (Row), SpalteArtNr (columnartnr), SpalteNild (ColumnPic),  _
Bildobjekt (object) und einen Index
Dim lngRow As Long
Dim lngIndex As Long
Dim ArtNr As String
Dim intColumnArtNr As Integer
Dim intColumnPic As Integer
Dim objShape As Object
Dim Dateinamen As String
Dim Verzeichnis As String
' Weist den Variablen SpalteArtNr (Column) und SpaltePic und Index Startwerte zu. In diesen  _
Spalten wird die artikelnummer gesucht und das Bild platziert.
intColumnArtNr = 2
intColumnPic = 1
lngIndex = 27
' Löscht jedes Bild in der Arbeitsmappe
For Each objShape In ActiveSheet.Shapes
If objShape.Type = msoPicture Then objShape.Delete
Next
For Each Zelle In Range("A13:A8000").SpecialCells(xlCellTypeVisible)
ArtNr = Trim$(Cells(Zelle.Row, intColumnArtNr).Text)
Dateinamen = Left(ArtNr, 2) & "_" & Mid(ArtNr, 4, 4) & "_" & Right(ArtNr, 4)
Verzeichnis = Left(ArtNr, 2) & "\" & Left(ArtNr, 2) & "_" & Mid(ArtNr, 4, 2) & "\"
If ArtNr  "" Then
If Dir$(strPath & Verzeichnis & Dateinamen & "_100" & ".jpg", vbNormal)  "" Then ' _
Prüft die Existenz eines Artikelbilds auf dem oben definierten Verzeichnis
Set objShape = ActiveSheet.Pictures.Insert(strPath & Verzeichnis & Dateinamen &  _
"_100" & ".jpg") 'Fügt das Artikelbild in das aktive Tabellenblatt ein
'Definiert die Position/Ausrichtung sowie Größe des Bilds
With objShape
.Left = Cells(Zelle.Row, intColumnPic).Left
.Top = Cells(Zelle.Row, intColumnPic).Top
.ShapeRange.Width = Cells(Zelle.Row, intColumnPic).Height - 10
End With
ElseIf Dir$(strPath & Verzeichnis & Dateinamen & ".jpg", vbNormal)  "" Then ' Prü _
ft die Existenz eines Artikelbilds auf dem oben definierten Verzeichnis
Set objShape = ActiveSheet.Pictures.Insert(strPath & Verzeichnis & Dateinamen &  _
".jpg") 'Fügt das Artikelbild in das aktive Tabellenblatt ein
'Definiert die Position/Ausrichtung sowie Größe des Bilds
With objShape
.Left = Cells(Zelle.Row, intColumnPic).Left
.Top = Cells(Zelle.Row, intColumnPic).Top
.ShapeRange.Width = Cells(Zelle.Row, intColumnPic).Width
End With
End If
End If
Next
Set objShape = Nothing
For Each objShape In ActiveSheet.Shapes
If objShape.Type = msoPicture Then
objShape.OnAction = "Bild_aendern"
End If
Next
End Sub
Danke und Grüße

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Makro läuft nicht "rund"
13.03.2017 18:15:52
Luschi
Hallo Marcel,
dieser Befehl kann so nicht korrekt sein:
.ShapeRange.Width = Cells(Zelle.Row, intColumnPic).Height- 10
zumal, im ElseIf-Zweig der Befehl so aussieht:
.ShapeRange.Width= Cells(Zelle.Row, intColumnPic).Width
Außerdem frage ich mich, warum Du die 'Height'-Eigenschaft nicht auch festlegst.
Gruß von Luschi
aus klein-Paris
AW: Makro läuft nicht "rund"
14.03.2017 08:45:57
Marcel
Hi Luschi,
danke für Deine Hinweise. Ich habe das Makro nur von einem Kollegen geerbt - kenne mich leider überhaupt nicht aus. Kannst Du bitte etwas ins Detail gehen, was ich wie abändern muss?
Danke und Grüße
Anzeige
Kann hier niemand helfen?
16.03.2017 16:01:45
Marcel
Ich komme leider nicht weiter.
Ausganglage ist im Prinzip Folgende:
Anhand der Artikelnummer die in Spalte B steht soll geprüft werden, ob ein Bild in einem definierten Verzeichnis vorliegt und wenn ja ein Thumbnail in Spalte A eingefügt werden.
Voraussetzungen:
1. Spaltenhöhe: 130 / Spaltenbreite: 24
2. Thumbnails sollen zentriert in der Größe eingefügt werden
3. Artikelnummer in Spalte B ist 10-stellig (xxxxxxxxxx)
4. Dateinamen des Bilds in Pfad sind in folgendem Format abgelegt: xx_xxxx_xxxx_100.jpg
5. Das Makro soll nur über die sichtbaren/gefilterten Zellen laufen
Danke und Grüße
Anzeige
AW: Kann hier niemand helfen?
17.03.2017 06:27:04
Luschi
Hallo Marcel,
hast Du denn die von mir aufgezeigte fehlerhafte Vba-Zeile korrigiert?
Zusätzlich kommt noch eine Vba-Zeile hinzu.

''Breite - korrigierte Zeile
.ShapeRange.Width = Cells(Zelle.Row, intColumnPic).Width
''Höhe - zusätzliche Zeile
.ShapeRange.Height = Cells(Zelle.Row, intColumnPic).Height
Gruß von Luschi
aus klein-Paris
AW: Kann hier niemand helfen?
17.03.2017 10:18:03
Marcel
Hallo Luschi,
ich habe es wie folgt angepasst (die -10 auch rausgenommen). Kannst Du mal bitte schauen, ob das so passt?
Das Grundproblem ist leider noch vorhanden: Die gezogenen Thumbnails liegen übereinander in der ersten Zelle und nicht zentriert sauber "neben" den Artikelnummern.
Danke und vele Grüße
Marcel
Public Sub prcInsertPicture()
' Legt das Dateiverzeichnis der Artikelbilder fest
Const strPath = "\\PFAD\"
' Definiert die Variablen Zeile (Row), SpalteArtNr (columnartnr), SpalteNild (ColumnPic) _
, _
Bildobjekt (object) und einen Index
Dim lngRow As Long
Dim lngIndex As Long
Dim ArtNr As String
Dim intColumnArtNr As Integer
Dim intColumnPic As Integer
Dim objShape As Object
Dim Dateinamen As String
Dim Verzeichnis As String
' Weist den Variablen SpalteArtNr (Column) und SpaltePic und Index Startwerte zu. In  _
diesen _
Spalten wird die artikelnummer gesucht und das Bild platziert.
intColumnArtNr = 2
intColumnPic = 1
lngIndex = 27
' Löscht jedes Bild in der Arbeitsmappe
For Each objShape In ActiveSheet.Shapes
If objShape.Type = msoPicture Then objShape.Delete
Next
For Each Zelle In Range("A13:A8000").SpecialCells(xlCellTypeVisible)
ArtNr = Trim$(Cells(Zelle.Row, intColumnArtNr).Text)
Dateinamen = Left(ArtNr, 2) & "_" & Mid(ArtNr, 4, 4) & "_" & Right(ArtNr, 4)
Verzeichnis = Left(ArtNr, 2) & "\" & Left(ArtNr, 2) & "_" & Mid(ArtNr, 4, 2) & "\"
If ArtNr  "" Then
If Dir$(strPath & Verzeichnis & Dateinamen & "_100" & ".jpg", vbNormal)  ""  _
Then ' _
Prüft die Existenz eines Artikelbilds auf dem oben definierten Verzeichnis
Set objShape = ActiveSheet.Pictures.Insert(strPath & Verzeichnis &  _
Dateinamen & _
"_100" & ".jpg") 'Fügt das Artikelbild in das aktive Tabellenblatt ein
'Definiert die Position/Ausrichtung sowie Größe des Bilds
With objShape
.Left = Cells(Zelle.Row, intColumnPic).Left
.Top = Cells(Zelle.Row, intColumnPic).Top
.ShapeRange.Width = Cells(Zelle.Row, intColumnPic).Width
.ShapeRange.Height = Cells(Zelle.Row, intColumnPic).Height
End With
ElseIf Dir$(strPath & Verzeichnis & Dateinamen & ".jpg", vbNormal)  "" Then '  _
Prü _
ft die Existenz eines Artikelbilds auf dem oben definierten Verzeichnis
Set objShape = ActiveSheet.Pictures.Insert(strPath & Verzeichnis &  _
Dateinamen & _
".jpg") 'Fügt das Artikelbild in das aktive Tabellenblatt ein
'Definiert die Position/Ausrichtung sowie Größe des Bilds
With objShape
.Left = Cells(Zelle.Row, intColumnPic).Left
.Top = Cells(Zelle.Row, intColumnPic).Top
.ShapeRange.Width = Cells(Zelle.Row, intColumnPic).Width
End With
End If
End If
Next
Set objShape = Nothing
For Each objShape In ActiveSheet.Shapes
If objShape.Type = msoPicture Then
objShape.OnAction = "Bild_aendern"
End If
Next
End Sub

Anzeige
AW: Kann hier niemand helfen?
17.03.2017 16:53:39
Luschi
Hallo Marcel,
habe Deinen Vba-Code jetzt mal ausprobiert und bei mir sieht das so aus:
Userbild
Den einzigen Befehl, den ich dazugesetzt habe, ist dieser:
.ShapeRange.LockAspectRatio = msoFalse
der steht vor:
.ShapeRange.Width = Cells(Zelle.Row, intColumnPic).Width
Damit wird das proportionale Seitenverhältnis des Bildes aufgehoben.
Gruß von Luschi
aus klein-Paris
AW: oT nachgefragt ...
17.03.2017 17:34:00
...
Hallo Luschi,
... hattest Du meine gestrige Mail erhalten?
Gruß Werner
.. , - ...
Anzeige
AW: oT nachgefragt ...
17.03.2017 17:50:50
Luschi
Hallo Werner,
leider NEIN!!!
Gruß von Luschi
aus klein-Paris
PS: habe Dir gerade eine Test-EMail geschickt
AW: oT neuer Versuch ...
17.03.2017 18:05:53
...
Hallo Luschi,
... hab eben meine gestrige Mail an die Test-Mail-Adresse weitergeleitet. Angekommen?
Gruß Werner
.. , - ...
AW: oT neuer Versuch ...
17.03.2017 18:18:00
Luschi
Hallo Werner,
nun JA!!!
Gruß von Luschi
aus klein-Paris

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige