Supportnet Computer
Planet of Tech

Supportnet / Forum / Tabellenkalkulation

Grafik mit VBA kopieren...





Frage

Moin Crackz, ich habe eine excel, deren Werte und Formate ich in eine andere Datei speicher. Das funktioniert dank des gesammelten VBA-Wissen von euch und zwei, drei äußerst bescheiden Ergänzungen meinerseits auch 1a, ABER jetzt ist in der Ursprungsdatei auch eine Grafik, die ich mitkopieren möchte. Dafür reichen meine VBA-Kenntnisse (so ziemlich gleich null) echt nicht aus. Bis her sieht das Makro so aus: Sub Datei() Cells.Copy Workbooks.Add Sheets("Tabelle1").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False ActiveWindow.DisplayZeros = False Dim Nachname_Vorname, Datum Nachname_Vorname = Split(Range("f14"), ",") ActiveWorkbook.SaveAs "H:\Eigene Dateien\" & Nachname_Vorname(0) _ & "_" & Nachname_Vorname(1) & "_" & Range("j14") & ".xls" End Sub Vielen Dank schon mal im Voraus. m-o-m

Antwort 1 von fürLau

Hallo

Um welche Art von
Zitat:
Grafik
handelt es sich denn?

Gruß

Antwort 2 von m-o-m

Moin,

zur Zeit png.

Format kann sich aber auch ändern.

Gruß

m-o-m

Antwort 3 von m-o-m

Hallo Crackz,

gibt´s hierzu keine Lösung, oder ist das etwa so leicht, dass man (ich) das im Schlaf können müsste???

Ich krieg dass echt nicht hin!!!

Grafik kann ich auch jpg, gif, tif, bmp abspeichern, wenn das weiterhilft.

Hoffe auf Antwort.

Gruß

m-o-m

Antwort 4 von JoeKe

Moin m-o-m,

ich bin durch einen anderen Thread auf eine mögliche Lösung für dein Problem gekommen.
Versuch es mal damit:

Sub Datei()
Dim Nachname_Vorname, Datum
ActiveWindow.DisplayZeros = False
Nachname_Vorname = Split(Range("f14"), ",")
ActiveWorkbook.SaveCopyAs "H:\Eigene Dateien\" & Nachname_Vorname(0) _
& "_" & Nachname_Vorname(1) & "_" & Range("j14") & ".xls"
End Sub


MfG

JöKe

Antwort 5 von fürLau

Hallo

Folgendes Makro kopiert alle Bilder aus Mappe1 nach Mappe2:

Sub copy()
Dim Pname As String, i%, Pleft As Double, Ptop As Double
For i = 1 To Workbooks("Mappe1").Sheets("Tabelle1").Shapes.Count
Workbooks("Mappe1").Sheets("Tabelle1").Shapes("Picture " & CStr(i)).copy
Ptop = Workbooks("Mappe1").Sheets("Tabelle1").Shapes("Picture " & CStr(i)).Top
Pleft = Workbooks("Mappe1").Sheets("Tabelle1").Shapes("Picture " & CStr(i)).Left
Workbooks("Mappe2").Sheets("Tabelle1").Paste
Workbooks("Mappe2").Sheets("Tabelle1").Shapes("Picture " & CStr(i)).Left = Pleft
Workbooks("Mappe2").Sheets("Tabelle1").Shapes("Picture " & CStr(i)).Top = Ptop
Next
End Sub

Gruß

Antwort 6 von m-o-m

Hallo,

ihr Zwei

@ JöKe: Vielen Dank soweit, aber (wenn ich das VBA soweit verstehe) ist dein Code für das kopieren und Abspeichern unter verantwortlich. Das funktioniert glücklicherweise schon. Oder verstehe ich das mal wieder nicht?

@ fürLau: Vielen Dank. Bei Mappe1 und Mappe2 klappt es wunderbar. ich bekomme das Makro nur nicht in meinen Code integriert.

Könnt Ihr mir da vielleicht helfen???

Danke schon mal für die Mühe, die Ihr euch gemacht habt.

bis hoffentlich bald

m-o-m

Antwort 7 von fürLau

Bitteschön:
Sub Datei()
Dim Nachname_Vorname, Datum
Dim Pname As String, i%, Pleft As Double, Ptop As Double, SM$, ZM$
SM = ActiveWorkbook.Name
Cells.copy
Workbooks.Add
ZM = Workbooks(Workbooks.Count).Name
Workbooks(ZM).Sheets("Tabelle1").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveWindow.DisplayZeros = False
For i = 1 To Workbooks(SM).Sheets("Tabelle1").Shapes.Count
Workbooks(SM).Sheets("Tabelle1").Shapes("Picture " & CStr(i)).copy
Ptop = Workbooks(SM).Sheets("Tabelle1").Shapes("Picture " & CStr(i)).Top
Pleft = Workbooks(SM).Sheets("Tabelle1").Shapes("Picture " & CStr(i)).Left
Workbooks(ZM).Sheets("Tabelle1").Paste
Workbooks(ZM).Sheets("Tabelle1").Shapes("Picture " & CStr(i)).Left = Pleft
Workbooks(ZM).Sheets("Tabelle1").Shapes("Picture " & CStr(i)).Top = Ptop
Next
Nachname_Vorname = Split(Range("f14"), ",")
Workbooks(ZM).SaveAs "H:\Eigene Dateien\" & Nachname_Vorname(0) _
& "_" & Nachname_Vorname(1) & "_" & Range("J14") & ".xls"
End Sub


Hoffe es klappt - da ungetestet weil ich Deine Daten nicht kenne Nachname_Vorname(x), Datum
Gruß

Antwort 8 von JoeKe

Hallo m-o-m,

mein Code lautet vereinfacht ausgedrückt:

Speicher eine Kopie der Aktivenmappe unter "Deine Vorgaben"

Du kannst ihn ohne Änderungen nutzen.

MfG
JöKe

Antwort 9 von m-o-m

Hallo Ihr zwei Genies (das ist Ernst gemeint),

@fürLau: bei der Zeile bleibt er stehen:
For i = 1 To Workbooks(SM).Sheets("Tabelle1").Shapes.Count

@JöKe: wenn ich nur Dein Makro nehme funzt es, aber somit wird ja die ganze Datei kopiert und nicht nur die Werte.

Hintergrund (wahrscheinlich viel zu spät):
Ein Rechnungsblatt kopiert Firma, Rechnungsnummer, -Datum, Wert in ein zweites Blatt und soll die Rechnung als Kopie speichern, wenn nun die ganze Datei gespeichert wird, wird somit ja auch die Übersicht gespeichert.

Hier ist jetzt das Makro inkl. des Makros von JöKe, er kopiert die Datei, aber jetzt wieder ohne Grafik!!!

Und ich weiß echt nicht warum???

Gruß

m-o-m



Sub Datum()
Dim Nachname_Vorname, Datum
ActiveWindow.DisplayZeros = False
Nachname_Vorname = Split(Range("k15"), ",")
ActiveWorkbook.SaveCopyAs "H:\Eigene Dateien\temp\Aroma\" & Nachname_Vorname(0) _
& "_" & Nachname_Vorname(1) & "_" & Range("j14") & ".xls"
Dim Zeile As Integer
Zeile = 2
Do While Worksheets(2).Cells(Zeile, 1) <> ""
Zeile = Zeile + 1
Loop
Worksheets(2).Cells(Zeile, 1) = Worksheets(1).Cells(14, 4)
Worksheets(2).Cells(Zeile, 2) = Worksheets(1).Cells(14, 5)
Worksheets(2).Cells(Zeile, 3) = Worksheets(1).Cells(9, 2)
Worksheets(2).Cells(Zeile, 4) = Worksheets(1).Cells(14, 10)
Worksheets(2).Cells(Zeile, 5) = Worksheets(1).Cells(48, 10)
Cells.copy
Workbooks.Add
Sheets("Tabelle1").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveWindow.DisplayZeros = False
End Sub

Antwort 10 von CaroS

Hallo,

ich ergänze mal. In Zelle F14 steht ein Text wie "Mustermann,Max" und in Zelle J14 ein Datum (z. B. 11.08.2004) - kann man vermuten, siehe
Workbook.SaveAs
-Befehl. Dann ergibt sich
Nachname_Vorname(0)
= "Mustermann" und
Nachname_Vorname(1)
= "Max" und wird anschließend zum neuen Dateinamen
"H:\Eigene Dateien\Mustermann_Max_11.08.2004.xls" zusammengesetzt.

Man hat es allerdings mit der Variablen
Datum
, nachdem sie deklariert wurde, nicht konsequent zu Ende gebracht mit
Datum = Range("J14")

und
Workbook.SaveAs "H:\Eigene Dateien\" & Nachname_Vorname(0) _ 
& "_" & Nachname_Vorname(1) & "_" & Datum & ".xls"
,
Workbook.SaveAs ... & Nachname_Vorname(1) & "_" & Datum & ".xls"
,
aber es funktioniert ja auch so.

Ja, wenn man das mit Deklarieren und Belegen der Variablen immer "ordentlich" macht, braucht man eben ein bisschen länger, so wie ich, aber ich hatte auch noch über eine andere Variante nachgedacht und kann die ja jetzt trotzdem noch mal vorstellen.

Zwischen den beiden ersten Varianten gibt es nämlich eine "Lücke". m-o-m kopiert nur Zellen (
Cells.Copy
) und sonst nichts, da fehlen die Bilder. JöKe dagegen kopiert gleich die ganze Datei (
ActiveWorkbook.SaveCopyAs
) mit allem drum und dran. Da dachte ich, dass es vielleicht auch reichen würde, bloß das aktuelle Tabellenblatt (komplett, also einschließlich aller Grafiken, Diagramme und sonstiger "Extras") zu kopieren.

Man braucht in m-o-ms Code eigentlich nur
Cells.Copy
gegen
ActiveSheet.Copy
auszutauschen und außerdem - das finde ich sehr erstaunlich und es hat lange gedauert, bis ich da drauf gekommen bin - sowohl den
Workbooks.Add
- als auch die beiden
Paste
-Befehle zu löschen! (Hier zur besseren Übersicht mit REM auskommentiert.)

Sub neueDatei()
REM Cells.Copy
ActiveSheet.Copy
REM Workbooks.Add
REM Sheets("Tabelle1").Range("A1").PasteSpecial _
REM Paste:=xlPasteValues, Operation:=xlNone, _
REM SkipBlanks:=False, Transpose:=False
REM Selection.PasteSpecial Paste:=xlPasteFormats, _
REM Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveWindow.DisplayZeros = False
Dim Nachname_Vorname, Datum ´REM Datum wird nicht benutzt
Nachname_Vorname = Split(Range("F14"), ",")
ActiveWorkbook.SaveAs "H:\Eigene Dateien\" & Nachname_Vorname(0) _
& "_" & Nachname_Vorname(1) & "_" & Range("J14") & ".xls"
End Sub


(Aber ich hab dann auch noch angefangen, mit den ActiveSheet.Shapes rumzuprobieren und bin nicht fertig geworden, weil ich ewig nach dem richtigen Typ gesucht habe. So ist es Mittag geworden.)

Gruß,
CaroS

Antwort 11 von JoeKe

Hallo m-o-m,

irgendwie hänge ich an meiner Lösung noch fest.
Ich habe sie jetzt so erweiter, dass erst eine Kopie unter deinem deffenierten Namen gespeichert wird. Danach wird die Datei nochmal geöffnet und alle Blätter von 2 bis zum Ende gelöscht. Das bedeutet die Rechnung muss auf Blatt 1 stehen. Nach dem löschen wird die Datei gespeichert und geschlossen. Konnte das aber nur an Hand einer zusammengebastelten Datei testen.

Sub Datei()
Dim Nachname_Vorname, Datum, blatt As Integer, WbName As String
Application.DisplayAlerts = False
Nachname_Vorname = Split(Range("f14"), ",")
ActiveWindow.DisplayZeros = False
WbName = "H:\Eigene Dateien\" & Nachname_Vorname(0) _
& "_" & Nachname_Vorname(1) & "_" & Range("j14") & ".xls"
ActiveWorkbook.SaveCopyAs WbName
Workbooks.Open Filename:=WbName
For blatt = Worksheets.Count To 2 Step -1
Sheets(blatt).Delete
Next
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub


MfG
JöKe

Antwort 12 von fürLau

@m-o-m
Wahrscheinlich heißt Dein Tabellenblatt anders als "Tabelle1", dann mußt Du (natürlich) Den Namen ersetzen z.B. "Rechnung".

@CaroS
Genial, einfach!! .;-)

Gruß

Antwort 13 von JoeKe

@ CaroS,

RESPEKT!!!!!!!! ;-)

Antwort 14 von m-o-m

Hallo Ihr Drei Superhirne,

tut mir leid, dass ich mich erst jetzt melde, hab noch ein paar andere Baustellen zu beackern.

Vielen Dank für Eure Mühe, klappt einwandfrei. Auch wenn ich nur einen Bruchteil von dem verstehe, was ihr da geschrieben habt.

DANKE! DANKE! DANKE!


Gruß m-o-m

Ich möchte kostenlos eine Frage an die Mitglieder stellen:


Ähnliche Themen:


Suche in allen vorhandenen Beiträgen: