Hej!
Har ett mycket irriterande problem. Sökt på google och diverse excelforum men inte lyckats hitta någon lösning.
Säkert enkelt men nu orkar jag inte pilla längre :).
Har en excelfil med ett flertal diagram och information. Ska skapa en rapport av detta utan länkar, utan all bakomliggande data.
Funkar bra att göra ett makro som kopierar klistrar in special: format, och sen kopiera klistra in special: värden.
Men sen ska jag ta alla diagrammen, klippa ut och klistra in "som enhanced metafile" (bildobjekt) eftersom dom tar mycket mindre plats. Rapporten ska mailas ut. Då stöter jag på problem eftersom alla diagram får nya nummer hela tiden när jag klipper ut klistrar in special. Om man kollar i Chart window så heter dom i stil med "Chart 79" osv.
Kan man namnge dom på något sätt? Eller finns det någon som har ett makro som loopar igenom en excelfil och konverterar alla diagram till "enhanced metafile" ?

Hej! Jag har haft i stort sett samma problem. Om man kan byta namn på dem vet jag inte men så här kan du konvertera dem till önskat format i alla fall.

<code>For J = 1 To ActiveSheet.ChartObjects.Count
ActiveSheet.ChartObjects(J).Activate
ActiveChart.ChartArea.Select
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
ActiveSheet.Range("I" & J * 25).Select 'Modifiera ber. på vart du vill ha bilden
ActiveSheet.PasteSpecial Format:="Bild (Förbättrad metafil)", Link:=False, DisplayAsIcon:=False
Next J</code>

Mvh, Janne

Tack!! Funkar bra!
Förutom att dom gamla diagrammen ligger kvar. Kan man köra Cut istället för Copy?
Har också problem med att få dom inklistrade på rätt ställe eftersom det inte är exakta mellanrum mellan varje diagram. Första ligger på rad 91 och andra på rad 125 t.ex.
Sen har jag även flera blad i samma arbetsbok, kan man få makrot att loopa igenom alla?

Tack för svaret! Uppskattas!

>Förutom att dom gamla diagrammen ligger kvar. Kan man köra Cut istället för Copy?

I min variant så jobbar jag med två Excel-dokument. En originalfil och en fil som bara innehåller den info som ska skickas. På så sätt behöver jag inte ta bort något utan bara kopiera över till det andra Excel-dokumentet.

>Har också problem med att få dom inklistrade på rätt ställe eftersom det inte är
>exakta mellanrum mellan varje diagram. Första ligger på rad 91 och andra på rad
>125 t.ex.

I det exempel jag gav dig var kopieraingen gjord i en loop eftersom du frågade efter det. Själv har jag koden upplagd så att jag kopierar diagrammen ett och ett vilket gör att jag kan bestämma vart de ska hamna.

>Sen har jag även flera blad i samma arbetsbok, kan man få makrot att loopa
>igenom alla?

Titta på Excel's objektmodell så tror jag att det klarnar. Workbooks -> Worksheets etc

Mvh, Janne

Tack igen! :)

Har lyckats lösa alla problem utom just placeringen, orsaken till att jag bad om en loop var att jag trodde att det kanske fanns någon "konverteringsloop" som placerade diagrammen på samma ställe. Så som jag har lagt upp det nu skapas en rapportfil genom att kopiera 4 blad i en array till en ny arbetsbok som sedan sparas ned med ett nytt namn+datum. Orsaken till att jag gör så är att det är utskriftsformat, några småbilder och textboxobjekt som ligger med. Blev enklast, men då ser allt ut som i originalet och därför måste jag klippa ut och klistra in i den filen.

Mvh
/Andreas

Jag snokade lite i objektmodellen och hittade egenskaperna för bildens position:

<code>Workbooks("Bok1").Worksheets("Blad1").Shapes("Picture 2").Top = 10
Workbooks("Bok1").Worksheets("Blad1").Shapes("Picture 2").Left = 10</code>

Mvh, Janne

Men hur vet jag vilket namn bilden kommer att få? När man kör copy chartarea och paste som enhanced metafile så får den inklistrade bilden bara ett nummer i ordningen av excel. När man sen använder sig av egenskaperna för bildens position så refererar den till ett annat nummer.


Mvh
/Andreas

Hmmm ... jo, du skrev tidigare att du kopierar bilderna till en NY arbetsbok. Det innebär att det inte finns några "shapes" i något "worksheet". Då kan du använda indexet i stället för namnet och utgå från att den först kopierade har index 1, den andra 2 osv.

<code>Workbooks("Bok1").Worksheets("Blad1").Shapes(1).Left = 10</code>

Har inte provat, men det borde bli så.

Mvh, Janne

Testa det men problemet är att textboxar, andra mindre bilder mm stör indexeringen.
Har försökt lösa det så här istället:


Dim o As Picture
Dim oSource As ChartObject

Sheets("Blad1").Select
iSourceChartsCount = ActiveSheet.ChartObjects.Count
For J = 1 To iSourceChartsCount
Set oSource = ActiveSheet.ChartObjects(J)
ActiveSheet.ChartObjects(J).Activate
ActiveChart.ChartArea.Select
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
ActiveSheet.PasteSpecial Format:="Bild (Förbättrad metafil)", Link:=False, DisplayAsIcon:=False
Set o = ActiveSheet.Pictures(ActiveSheet.Pictures.Count)
o.Left = oSource.Left
o.Top = oSource.Top
Next J

Det funkar men när jag sen försöker deletea charts i den nyskapade rapportfilen med detta makro så följer dom inklistrade metafilerna med :(.
Verkar som dom är grupperade på något sätt, kan inte hitta nåt sätt att lösa det på??



Windows("rapport.xls").Activate

Sheets("blad1").Activate
For Each obj In ActiveSheet.ChartObjects
obj.delete
Next

Mvh
/Andreas

Vi har löst problemet genom att
loopa igenom alla diagramobjekt och
hämta pos och namn
Därefter skapas gifbilder av diagrammen

Gifbilderna infogas på samma pos som
diagrammen

Diagrammen raderas och de giffar som
sparats raderas

Bifogar den funktion som vi använder

Den måste förstås anpassas för dina behov

<code>
' ---------------------------------
' BuildAllTempGif
' ---------------------------------

' Bygg alla .GIF filer enligt FilePrefix & "GIF" & # & ".GIF"
' Loopa alla ChartObject och skapa GIF-filer av dom
' Returnera top, vänster position samt namn på ChartObjekten
' Importera de skapade gif bilderna på samma position som ChartObjekten
' Radera alla ChartObjekten
' Radera alla gif filer

' FilePrefix = innehåller path och filnamnets inledning
' SheetName$ = Sheetname där ChartObjekt finns
' NumGifs% = Antal skapade Gif-filer
' ChartObjectTopPos() Topp position på ChartObjekt i bilden
' ChartObjectLeftPos() Vänster position på ChartObject i bilden
' ChartObjectNames() = Namn på ChartObject i bilden
' ErrMsg$ = Returnerat felmeddelande (OM Misslyckat)


Public Function BuildAllTempGif(ByVal FilePrefix$, ByVal SheetName$, NumGifs%, _
ChartObjectNames() As String, ChartObjectTopPos() As Integer, ChartObjectLeftPos() As Integer, errmsg$) As Boolean

Dim CurrentChart, Fname$, i%, dimStr%

BuildAllTempGif = False ' Assume error
errmsg$ = ""

On Error GoTo BuildAllTempGif_err

' En loop startas Först skapas gif filerna

NumGifs% = 0 ' Inga Giffar än
dimStr% = 10
ReDim ChartObjectTopPos(dimStr)
ReDim ChartObjectLeftPos(dimStr)
ReDim ChartObjectName(dimStr)

If Sheets(SheetName$).ChartObjects.Count = 0 Then ' Det finns inga ChartObject
Exit Function
End If

For i = 1 To Sheets(SheetName$).ChartObjects.Count
Set CurrentChart = Sheets(SheetName$).ChartObjects(i).Chart
' Sätter sökväg till temporära giffar
Fname = FilePrefix$ & "GIF" & CStr(i) & ".GIF"
NumGifs% = NumGifs% + 1
If NumGifs% > dimStr Then
dimStr = dimStr + 10
ReDim Preserve ChartObjectTopPos(dimStr)
ReDim Preserve ChartObjectLeftPos(dimStr)
ReDim Preserve ChartObjectName(dimStr)
End If
' Hämtar top, vänster position samt namn för diagramobjektet
ChartObjectTopPos(NumGifs%) = Sheets(SheetName$).ChartObjects(i).Top
ChartObjectLeftPos(NumGifs%) = Sheets(SheetName$).ChartObjects(i).Left
ChartObjectName(NumGifs%) = Sheets(SheetName$).ChartObjects(i).Name
' Exporterar diagramobjektet till en gif
Call CurrentChart.Export(Fname, "GIF", False) ' Skapa GIF-bild

' Gif fil importeras och positioneras
With Application.Sheets(SheetName$)
With .Pictures.Insert(Fname)
.Top = ChartObjectTopPos(NumGifs%)
.Left = ChartObjectLeftPos(NumGifs%)
End With
End With

Err.Clear
Next i
For i = 1 To NumGifs%
' Raderar diagramobjektet och temp giffar
Sheets(SheetName$).ChartObjects(ChartObjectName(i)).Delete
If Dir(FilePrefix$ & "GIF" & CStr(i) & ".GIF") <> "" Then
Kill FilePrefix$ & "GIF" & CStr(i) & ".GIF"
End If
Next i

BuildAllTempGif = True ' OK

Exit Function

BuildAllTempGif_err:
errmsg$ = "Fel i BuildAllTempGif: " & Err.Description & " [" & Err.Number & "]"
Err.Clear
Exit Function
End Function
</code>

Tack Thommy!

Lyckades faktiskt lösa problemet själv med hjälp av Jannes kod samt egna kodsnuttar.

Ska definitivt testa din lösning, kanske är mycket bättre.
Bifogar det som fungerar för mig om någon är intresserad :)


Sub Rapport_Makro()
'
' Skapa_Rapport
' Macro Created by Andreas
'

'
Dim o As Picture
Dim oSource As ChartObject





Workbooks.Add
ActiveWorkbook.SaveAs Filename:="C:\Temp\rapport.xls", FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
Windows("Original.xls").Activate
Sheets(Array("One", "Two", "Three", "Four")). _
Select
Sheets("Four").Activate
Sheets(Array("One", "Two", "Three", "Four")). _
Copy Before:=Workbooks("rapport.xls").Sheets(1)
Windows("Original.xls").Activate
Sheets("One").Select
Windows("rapport.xls").Activate
ActiveWorkbook.BreakLink Name:= _
"C:\Temp\Original.xls", Type:= _
xlExcelLinks


Application.DisplayAlerts = False

Windows("rapport.xls").Activate
Sheets("Sheet1").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Sheet2").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Sheet3").Select
ActiveWindow.SelectedSheets.Delete


Application.DisplayAlerts = True

Windows("rapport.xls").Activate
Sheets("One").Activate
For Each obj In ActiveSheet.ChartObjects
obj.Delete
Next

'Sheets("Four").Activate
For Each obj In ActiveSheet.Buttons
obj.Delete
Next


Windows("Original.xls").Activate
Sheets("One").Select
iSourceChartsCount = ActiveSheet.ChartObjects.Count
For J = 1 To iSourceChartsCount
Windows("Original.xls").Activate
Sheets("One").Select
Set oSource = ActiveSheet.ChartObjects(J)
ActiveSheet.ChartObjects(J).Activate
ActiveChart.ChartArea.Select
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
Windows("rapport.xls").Activate
Sheets("One").Select
ActiveSheet.PasteSpecial Format:="Bild (Förbättrad metafil)", Link:=False, DisplayAsIcon:=False
'Debug.Print ActiveSheet.Pictures.Count
Set o = ActiveSheet.Pictures(ActiveSheet.Pictures.Count)
o.Left = oSource.Left
o.Top = oSource.Top
Next J



Sheets("Two").Activate
For Each obj In ActiveSheet.ChartObjects
obj.Delete
Next


Windows("Original.xls").Activate
Sheets("Two").Select
iSourceChartsCount = ActiveSheet.ChartObjects.Count
For J = 1 To iSourceChartsCount
Windows("Original.xls").Activate
Sheets("Two").Select
Set oSource = ActiveSheet.ChartObjects(J)
ActiveSheet.ChartObjects(J).Activate
ActiveChart.ChartArea.Select
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
Windows("rapport.xls").Activate
Sheets("Two").Activate
ActiveSheet.PasteSpecial Format:="Bild (Förbättrad metafil)", Link:=False, DisplayAsIcon:=False
'Debug.Print ActiveSheet.Pictures.Count
Set o = ActiveSheet.Pictures(ActiveSheet.Pictures.Count)
o.Left = oSource.Left
o.Top = oSource.Top
Next J



Sheets("Three").Activate
For Each obj In ActiveSheet.ChartObjects
obj.Delete
Next



Windows("Original.xls").Activate
Sheets("Three").Select
iSourceChartsCount = ActiveSheet.ChartObjects.Count
For J = 1 To iSourceChartsCount
Windows("Original.xls").Activate
Sheets("Three").Select
Set oSource = ActiveSheet.ChartObjects(J)
ActiveSheet.ChartObjects(J).Activate
ActiveChart.ChartArea.Select
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
Windows("rapport.xls").Activate
Sheets("Three").Select
ActiveSheet.PasteSpecial Format:="Bild (Förbättrad metafil)", Link:=False, DisplayAsIcon:=False
Debug.Print ActiveSheet.Pictures.Count
Set o = ActiveSheet.Pictures(ActiveSheet.Pictures.Count)
o.Left = oSource.Left
o.Top = oSource.Top
Next J



Sheets("Four").Activate
For Each obj In ActiveSheet.ChartObjects
obj.Delete
Next




Windows("Original.xls").Activate
Sheets("Four").Select
iSourceChartsCount = ActiveSheet.ChartObjects.Count
For J = 1 To iSourceChartsCount
Windows("Original.xls").Activate
Sheets("Four").Select
Set oSource = ActiveSheet.ChartObjects(J)
ActiveSheet.ChartObjects(J).Activate
ActiveChart.ChartArea.Select
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
Windows("rapport.xls").Activate
Sheets("Four").Select
ActiveSheet.PasteSpecial Format:="Bild (Förbättrad metafil)", Link:=False, DisplayAsIcon:=False
Debug.Print ActiveSheet.Pictures.Count
Set o = ActiveSheet.Pictures(ActiveSheet.Pictures.Count)
o.Left = oSource.Left
o.Top = oSource.Top
Next J





Windows("rapport.xls").Activate


Sheets("Two").Select
Range("A4").Select
Sheets("Three").Select
Range("A4").Select
Sheets("Four").Select
Range("A4").Select
Sheets("One").Select
Range("A4").Select

ActiveWorkbook.Save



Windows("Original.xls").Activate
Sheets("One").Select
Range("L1").Select
End Sub


Tack för all hjälp!

Mvh
/Andreas

Tänkte på din ursprungsfråga angående att namnge diagrammen

Jag brukar göra det i direktfönstret i VBA

?Application.ActiveSheet.Chartobjects.count 'ger antalet diagramobjekt

?Application.ActiveSheet.Chartobjects(1).name ' ger namnet på det första

Application.ActiveSheet.Chartobjects(1).name = "dittnamn" ' sätter ett namn på det första

osv...