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