Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Tabelle Kopieren mit Shapes position

Tabelle Kopieren mit Shapes position
Karel
Hallo Leute,
Makro 1 kopiert Tabelle im neue Arbeitmappe inklusiv Formatierung soweit ok,
aber Bilder werden nicht mit kopiert.
Makro 2, Kopiert alle Bilder und Zeichen Objekten inklusiv Position, aber nicht Format von Tabelle
1.) Wie kann man von Makro 2 dass das Teil was Bilder mit kopiert mit Position, im Makro 1 integrieren
2.) Bilder in Tabelle habe ein klick Ereignis bild vergrößern, bei Kopieren im neue Arbeitsmappe sollte diese klick Ereignis euch entfernt werden.
Makro 1
Sub Makro1() 'https://www.herber.de/forum/archiv/1032to1036/t1034766.htm (Tino)
Dim myTab As Worksheet
Dim strName As String
strName = ActiveSheet.Name
ActiveSheet.Cells.Copy
Set myTab = Sheets.Add
myTab.Cells.PasteSpecial (xlPasteValues)
myTab.Cells.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
myTab.Move
ActiveSheet.Name = strName
'hier kannst Du diese Datei irgendwo speichern oder sonstwas damit machen
End Sub
Makro 2
Sub CopyShapesAndPlaceIt() 'https://www.herber.de/forum/archiv/648to652/t648841.htm (Sep)
Dim shp As Shape
Dim ws1 As Worksheet, ws2 As Worksheet
Dim x As Double, y As Double
Set ws1 = Workbooks("73743_26 (2).xls").Worksheets("Tabelle1")
Set ws2 = Workbooks("Mappe1.xls").Worksheets("Tabelle1")
For Each shp In ws1.Shapes
If shp.Type = 13 Or shp.Type = 17 Then
With shp
x = .Left
y = .Top
.Copy
End With
ws2.Paste
With ws2.Shapes(ws2.Shapes.Count)
.Left = x
.Top = y
End With
End If
Next
End Sub

Grüße
Karel

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Tabelle Kopieren mit Shapes position
06.03.2011 22:19:04
Josef

Hallo Karel,
probier mal.
Sub CopyWithShapes()
  Dim objSh As Worksheet, objWB As Workbook
  Dim objShp As Shape
  Dim dblX As Double, dblY As Double, lngIndex As Long
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
  End With
  
  Set objSh = ActiveSheet
  Set objWB = Workbooks.Add(xlWBATWorksheet)
  
  objSh.Cells.Copy
  
  With objWB.Sheets(1)
    .Name = objSh.Name
    .Cells.PasteSpecial xlPasteValues
    .Cells.PasteSpecial xlPasteFormats
    Application.CutCopyMode = False
    
    For Each objShp In objSh.Shapes
      If objShp.Type = 13 Or objShp.Type = 17 Then
        With objShp
          .Name = "ToCopy_" & lngIndex
          dblX = .Left
          dblY = .Top
          .Copy
        End With
        
        .Paste
        With .Shapes("ToCopy_" & lngIndex)
          .Left = dblX
          .Top = dblY
          .OnAction = ""
        End With
        lngIndex = lngIndex + 1
      End If
    Next
  End With
  
  ErrExit:
  
  If Err.Number <> 0 Then
    MsgBox "Fehler:" & vbTab & Err.Number & vbLf & vbLf & Err.Description, vbExclamation, "Fehler"
  End If
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
  End With
  
  Set objWB = Nothing
  Set objSh = Nothing
End Sub



Gruß Sepp

Anzeige
AW: Tabelle Kopieren mit Shapes position
07.03.2011 20:20:25
karel
Guten abend Sepp,
Habe Heute auf der Arbeit Makro getestet unter Excel 2007, alles wird Kopiert aber Bilder verrutschen Langsam aber sicher aus ihre Zellbereich.
So habe soeben zuhause unter Excel 2003 getestet, da lauft alles Spitze.
Was kann der Ursachen sein, kannst du dass unter Excel 2007 auch einmall gegen prüfen
Beste Grüße
Karel
AW: Tabelle Kopieren mit Shapes position
07.03.2011 22:23:04
Josef

Hallo Karel,
ich habe den Code unter xl2007 erstellt und getestet, kann das von dir beschriebene verhalten nicht nachvollziehen.

Gruß Sepp

Anzeige
AW: Tabelle Kopieren mit Shapes position
08.03.2011 16:38:12
Josef

Hallo Karel,
tatsächlich werden nicht alle Zeilen mit der richtigen Zeilenhöhe übernommen.
So gehts.
' **********************************************************************
' Modul: CopyWithShapes Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub CopyWithShapes()
  Dim objSh As Worksheet, objWB As Workbook
  Dim objShp As Shape
  Dim dblX As Double, dblY As Double, dblRowHeight As Double
  Dim lngIndex As Long, lngRow As Long
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
  End With
  
  Set objSh = ActiveSheet
  Set objWB = Workbooks.Add(xlWBATWorksheet)
  
  objSh.Cells.Copy
  
  
  With objWB.Sheets(1)
    .Name = objSh.Range("J1").Value '.Name = objSh.Name standard Namen von Tabelle
    .Cells.PasteSpecial xlPasteValues
    .Cells.PasteSpecial xlPasteFormats
    Application.CutCopyMode = False
    
    For lngRow = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
      .Rows(lngRow).RowHeight = objSh.Rows(lngRow).RowHeight
    Next
    
    For Each objShp In objSh.Shapes
      If objShp.Type = 13 Or objShp.Type = 17 Then
        With objShp
          .Name = "ToCopy_" & lngIndex
          dblX = .Left
          dblY = .Top
          .Copy
        End With
        
        .Paste
        With .Shapes("ToCopy_" & lngIndex)
          .Left = dblX
          .Top = dblY
          .OnAction = ""
        End With
        lngIndex = lngIndex + 1
      End If
    Next
  End With
  
  ErrExit:
  
  If Err.Number <> 0 Then
    MsgBox "Fehler:" & vbTab & Err.Number & vbLf & vbLf & Err.Description, vbExclamation, "Fehler"
  End If
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
  End With
  
  Set objWB = Nothing
  Set objSh = Nothing
End Sub


Gruß Sepp

Anzeige
AW: Tabelle Kopieren mit Shapes position
09.03.2011 11:55:22
Karel
Hallo Sepp,
Vielen Dank hat alles geklappt,
phänomen veschieben Shapes passiert auch wenn ZoomFaktor Kleiner dann 100% ist.
Bester Grüße
Karel

308 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige