Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1268to1272
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

Shapes werden nicht korrekt positioniert

Shapes werden nicht korrekt positioniert
Frischy1990
Guten Morgen,
ich habe folgendes Problem.
Aus einer Tabelle werden Grafiken/Bilder in eine andere Arbeitsmappe kopiert. Dabei haben diese eine feste Position in der sie stets platziert werden sollen und sich an der rechten oberen Zellecke ausrichten. Bei einigen klappt das, bei einigen leider nicht. Ich habe absolut keine Ahnung wie es zu diesem Fehler kommt und wie ich den beheben kann.
Ich hoffe jemand von euch kennt eine Möglichkeit!
Schaut euch am besten mal die Beispielmappe an,markiert Zeilen 9-12 und klickt anschließend oben auf das PLAY-Logo.. dann startet das Makro. Im unten Teil der neu enstandenen Arbeitsmappe sind dann 1-2 Grafiken zu sehen. Bei Tabellenblatt (2) und (3) sind diese am richtigen Ort positioniert, bei (1) und (leer) leider versetzt darüber. Vllt kommt ja jemandem der Fehler bekannt vor?!
https://www.herber.de/bbs/user/80760.xlsm
Vielen Dank im Vorraus!
LG Frischy1990

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Shapes werden nicht korrekt positioniert
27.06.2012 13:14:28
Frischy1990
Hat keiner eine Idee?
AW: Shapes werden nicht korrekt positioniert
03.07.2012 15:22:22
fcs
Hallo Frischy,
ich hab mal ein wenig rumprobiert.
Folgende Sachen hab ich angepasst:
1. Do Events alle deaktiviert
2. Die Steckbrief-Datei bleibt immer die aktive Datei
3. Bildschirmaktualisierung bleibt während der Kopieraktionen deaktiviert
4. Shapes werden ohne Namensänderung in den Steckbrief kopiert
5. Einfügezellen werden vor dem Einfügen der Shapes selektiert
Es scheint jetzt zu funktionieren. Was jetzt die entscheidende Änderung war kann ich nicht genau sagen.
Gruß
Franz
Sub Steckbrief_erstellen()
Dim Datenbank As Workbook, Steckbrief As Workbook, objSh As Worksheet
Dim lngRow As Long
Dim strName As String, strNamT As String
Dim objImg As Object
Dim lngCalc As Long, lngC As Long
Dim arZeilen, lngZ As Long
'   DoEvents
Set Datenbank = ActiveWorkbook
arZeilen = ListeZeilenOhneDup(Selection)      ' Markierte Zeilen in Array
'Arbeitsmappen Check durchführen
If Dir("C:\temp\machine.xlsx") = "" Then
Workbooks.Add
ActiveWorkbook.SaveAs Filename:="C:\Temp\machine.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Else
Workbooks.Open "C:\temp\machine.xlsx"
End If
'   DoEvents
Set Steckbrief = ActiveWorkbook
'   ChDir "C:\Temp"
Datenbank.Sheets("Vorlage Steckbrief").Visible = True 'einblenden der Steckbrief Vorlage
Application.ScreenUpdating = False
For lngZ = 0 To UBound(arZeilen)
lngRow = arZeilen(lngZ)                      'Makro in jeweiliger Zeile ausführen
Datenbank.Sheets("Vorlage Steckbrief").Copy before:=Steckbrief.Sheets(1)
Set objSh = Steckbrief.Sheets(1)       ' neues Tabellenblatt - Steckbrief
With Datenbank.Sheets("Database")
' Benennen des Tabellenblattes
strNamT = .Cells(lngRow, 3) & " " & _
.Cells(lngRow, 6)
strName = strNamT
lngC = 0
Do While SheetExist(strName, Steckbrief)
lngC = lngC + 1
strName = strNamT & " (" & lngC & ")"
Loop
On Error Resume Next
objSh.Name = strName
'Bezeichnung alles andere vorübergehend enttfernt
objSh.Cells(11, 3) = .Cells(lngRow, 1).Text 'Country
'DoEvents
'BILDER
'process-flow of component 1
Set objImg = getPicture(.Cells(lngRow, 63))
If Not objImg Is Nothing Then
Cells(34, 3).Select
objImg.Copy
objSh.Paste
With objSh.Shapes(objSh.Shapes.Count)
'            .Name = "img_63"
.Top = objSh.Cells(34, 3).Top + 1
.Left = objSh.Cells(34, 3).Left
End With
End If
'process-flow of component 2
Set objImg = getPicture(.Cells(lngRow, 64))
If Not objImg Is Nothing Then
Cells(37, 3).Select
objImg.Copy
objSh.Paste
With objSh.Shapes(objSh.Shapes.Count)
'            .Name = "img_64"
.Top = objSh.Cells(37, 3).Top + 1
.Left = objSh.Cells(37, 3).Left
End With
End If
Application.GoTo objSh.Range("A1"), True
End With
'   DoEvents
Next lngZ
Datenbank.Sheets(1).Activate
'ausblenden der Steckbrief Vorlage
Datenbank.Sheets("Vorlage Steckbrief").Visible = xlVeryHidden
With Application
Datenbank.Save
End With
Application.GoTo objSh.Range("A1"), True
Steckbrief.Save
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige