excel/powerpoint

tuskastunut kopioija

Osaisko joku neuvoa miten saisi makrolla kopioitua excelista kaaviot(50 kpl) kuvina poverpointiin, jokainen omalle dialleen?

10

343

Äänestä

    Vastaukset

    Anonyymi (Kirjaudu / Rekisteröidy)
    5000
    • joskus vba

      ei käsittääkseni onnistu, eli VBA:lla pitänee koodata. ellei se ole ennestään (hyvin) tuttua, veikkaan, että 50 kuvaa menee ctrl-c ctrl-v :llä paljon nopeammin.

      • tuskastunut kopioija

        Yritin tuota nauhoiusta kanssa, ei se tosiaan toimi. Ongelmaksi tuli kun noita 50 kpl settejä on 36 kpl, ja toistuu vielä 3 kertaa vuodessa
        Pysyn luomaan excel makrolla kyllä uuden diaesityksen, mutta en liittämään siihen tuota dian kopiointia, siinä varsinainen ongelma
        Tässä alkupätkää ...

        Sub PowerPointtia_excelista()

        Dim ppApp As PowerPoint.Application
        Dim myPpt As PowerPoint.Presentation

        'muodostetaan powerpoint instanssi
        Set ppApp = New PowerPoint.Application
        With ppApp
        .Visible = True
        End With

        ' aloitetaan uusi esitys
        Set myPpt = ppApp.Presentations.Add

        ' luodaan esitykseen uusi sivu tyhjällä rakenteella
        ppApp.ActiveWindow.View.GotoSlide Index:=ppApp.ActivePresentation.Slides.Add(Index:=1, Layout:=ppLayoutBlank).SlideIndex

      • tuosta apuja
        tuskastunut kopioija kirjoitti:

        Yritin tuota nauhoiusta kanssa, ei se tosiaan toimi. Ongelmaksi tuli kun noita 50 kpl settejä on 36 kpl, ja toistuu vielä 3 kertaa vuodessa
        Pysyn luomaan excel makrolla kyllä uuden diaesityksen, mutta en liittämään siihen tuota dian kopiointia, siinä varsinainen ongelma
        Tässä alkupätkää ...

        Sub PowerPointtia_excelista()

        Dim ppApp As PowerPoint.Application
        Dim myPpt As PowerPoint.Presentation

        'muodostetaan powerpoint instanssi
        Set ppApp = New PowerPoint.Application
        With ppApp
        .Visible = True
        End With

        ' aloitetaan uusi esitys
        Set myPpt = ppApp.Presentations.Add

        ' luodaan esitykseen uusi sivu tyhjällä rakenteella
        ppApp.ActiveWindow.View.GotoSlide Index:=ppApp.ActivePresentation.Slides.Add(Index:=1, Layout:=ppLayoutBlank).SlideIndex

        http://www.computing.net/answers/office/error-using-macro-to-copy-from-excel-to-ppt/9433.html

      • kunde
      • tuskastunut kopioija
        kunde kirjoitti:

        Missäs noi 50 kaaviota on työkirjassa?
        Samassa taulukossa vaiko eri taulukossa vaiko kaaviosivuilla?
        Miten nimetty?
        Eiköhän se noilla tiedolla onnistu jo melko helposti

        Samassa taulukossa, nimetty esim "kaavio 3, kaavio 4"

      • muuan mies
        tuskastunut kopioija kirjoitti:

        Samassa taulukossa, nimetty esim "kaavio 3, kaavio 4"

        Tuolla on toinen vastaava makro:
        http://peltiertech.com/Excel/XL_PPT.html#chartstitlesslides
        "Paste Each Embedded Chart in the Active Worksheet into a New Slide in the Active Presentation, using the Chart Title as the Slide Title" -makro lisää PP dian otsikoksi sen kaavion otsikon.

        Ja nimim. "tuosta apuja" viestiin viitaten VBE:ssä pitää olla Tools References MS PP Object Library olla ruksattuna...

      • kunde
        muuan mies kirjoitti:

        Tuolla on toinen vastaava makro:
        http://peltiertech.com/Excel/XL_PPT.html#chartstitlesslides
        "Paste Each Embedded Chart in the Active Worksheet into a New Slide in the Active Presentation, using the Chart Title as the Slide Title" -makro lisää PP dian otsikoksi sen kaavion otsikon.

        Ja nimim. "tuosta apuja" viestiin viitaten VBE:ssä pitää olla Tools References MS PP Object Library olla ruksattuna...

        ihan hyvät linkit oli annettu...
        Tossa nyt koodi, jossa ei tartte aukaista Powerpointia etukäteen tai jos esitys on jo auki -
        lisää aktiivisen esityksen loppuun kaaviot...

        moduuliin...

        Dim powApp As PowerPoint.Application
        Dim powPres As PowerPoint.Presentation
        Dim powSlide As PowerPoint.Slide
        Dim laskuri As Long

        Sub KaaviotPowerpointtiin()
        ' Aseta viittaus Microsoft PowerPoint Object Library
        If ActiveSheet.ChartObjects.Count = 0 Then
        MsgBox "Aktiivinen taulukko ei sisällä kaavioita!!!", vbInformation
        Exit Sub
        End If
        OnkoPowerpoint = TsekkaaPowerpoint() 'tsekataan onko Powerpoint käynnissä
        If OnkoPowerpoint Then
        Set powApp = GetObject(, "Powerpoint.Application")
        Else
        Set powApp = CreateObject("Powerpoint.application")
        powApp.Visible = True
        End If

        If powApp.Presentations.Count = 0 Then
        powApp.Presentations.Add
        End If


        For laskuri = 1 To ActiveSheet.ChartObjects.Count

        With ActiveSheet.ChartObjects(laskuri).Chart
        .CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
        End With

        If powApp.ActivePresentation.Slides.Count = 0 Then
        Set powSlide = powApp.ActivePresentation.Slides.Add(1, ppLayoutBlank)
        Else
        powApp.ActivePresentation.Slides.Add powApp.ActivePresentation.Slides.Count 1, ppLayoutBlank

        End If

        powApp.ActiveWindow.View.GotoSlide powApp.ActivePresentation.Slides.Count
        Set powSlide = powApp.ActivePresentation.Slides(powApp.ActivePresentation.Slides.Count)
        powSlide.Shapes.Paste.Select
        powApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
        powApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
        Next
        Set powSlide = Nothing
        Set powPres = Nothing
        Set powApp = Nothing
        End Sub

        Function TsekkaaPowerpoint() As Boolean
        On Error Resume Next
        Set powApp = GetObject(, "Powerpoint.Application")
        TsekkaaPowerpoint = (Error.Number = 0)
        Set powApp = Nothing
        Err.Clear
        End Function

      • tuskastunut kopioija
        kunde kirjoitti:

        ihan hyvät linkit oli annettu...
        Tossa nyt koodi, jossa ei tartte aukaista Powerpointia etukäteen tai jos esitys on jo auki -
        lisää aktiivisen esityksen loppuun kaaviot...

        moduuliin...

        Dim powApp As PowerPoint.Application
        Dim powPres As PowerPoint.Presentation
        Dim powSlide As PowerPoint.Slide
        Dim laskuri As Long

        Sub KaaviotPowerpointtiin()
        ' Aseta viittaus Microsoft PowerPoint Object Library
        If ActiveSheet.ChartObjects.Count = 0 Then
        MsgBox "Aktiivinen taulukko ei sisällä kaavioita!!!", vbInformation
        Exit Sub
        End If
        OnkoPowerpoint = TsekkaaPowerpoint() 'tsekataan onko Powerpoint käynnissä
        If OnkoPowerpoint Then
        Set powApp = GetObject(, "Powerpoint.Application")
        Else
        Set powApp = CreateObject("Powerpoint.application")
        powApp.Visible = True
        End If

        If powApp.Presentations.Count = 0 Then
        powApp.Presentations.Add
        End If


        For laskuri = 1 To ActiveSheet.ChartObjects.Count

        With ActiveSheet.ChartObjects(laskuri).Chart
        .CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
        End With

        If powApp.ActivePresentation.Slides.Count = 0 Then
        Set powSlide = powApp.ActivePresentation.Slides.Add(1, ppLayoutBlank)
        Else
        powApp.ActivePresentation.Slides.Add powApp.ActivePresentation.Slides.Count 1, ppLayoutBlank

        End If

        powApp.ActiveWindow.View.GotoSlide powApp.ActivePresentation.Slides.Count
        Set powSlide = powApp.ActivePresentation.Slides(powApp.ActivePresentation.Slides.Count)
        powSlide.Shapes.Paste.Select
        powApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
        powApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
        Next
        Set powSlide = Nothing
        Set powPres = Nothing
        Set powApp = Nothing
        End Sub

        Function TsekkaaPowerpoint() As Boolean
        On Error Resume Next
        Set powApp = GetObject(, "Powerpoint.Application")
        TsekkaaPowerpoint = (Error.Number = 0)
        Set powApp = Nothing
        Err.Clear
        End Function

        Suunnattomat kiitokset, noinhan tuo menee, ja hermotkin säästyy....

    • Apua kaivataan

      Hei!

      Olisi samaan asiaan liityvä ongelma: Pitäisi kopioida 26 kuvaajaa (kuvana) valmiiseen powerpoint raporttipohjaan omille sivuilleen ja tiettyyn kohtaan. Ongelma on, että eri exceleitä ja on kymmeniä, joten copy paste menetelmä vie kauan aikaa.

      Kiitos!

      • kunde

        Lisäkyssäri2
        Missäs noi 26 kaaviota on työkirjassa?
        Samassa taulukossa vaiko eri taulukossa vaiko kaaviosivuilla?
        onko ne kuvia ???
        miten nimetty ja onko aina samannimisessä taulukossa?

        helpointa lienee kun laitat kyssärin mallitiedostoineen http://www.kundepuu.com (vaatii rekisteröitymisen- lukea voi ilman rekisteröitymistä)

    Ketjusta on poistettu 0 sääntöjenvastaista viestiä.

    Takaisin ylös

    Luetuimmat keskustelut

    1. Hengenvaaralliset kiihdytysajot päättyivät karmealla tavalla, kilpailija kuoli

      Onnettomuudesta on aloitettu selvitys. Tapahtuma keskeytettiin onnettomuuteen. Tapahtumaa tutkitaan paikan päällä yhtei
      Kauhava
      198
      6908

    2. Ootko rakastunut?

      Kerro pois nyt
      Ikävä
      159
      2036

    3. Onhan sulla nainen parempi mieli

      Nyt? Ainakin toivon niin.
      Ikävä
      113
      1688

    4. Ujosteletko tosissaan vai mitä oikeen

      Himmailet???? Mitä pelkäät?????
      Ikävä
      51
      1390

    5. Suureksi onneksesi on myönnettävä

      Että olen nyt sitten mennyt rakastumaan sinuun. Ei tässä mitään, olen kärsivällinen ❤️
      Ikävä
      55
      1238

    6. Möykkähulluus vaati kuolonuhrin

      Nuori elämä menettiin täysin turhaan tällä järjettömyydellä! Toivottavasti näitä ei enää koskaan nähdä Kauhavalla! 😢
      Kauhava
      50
      1098

    7. Älä mies pidä mua pettäjänä

      En petä ketään. Älä mies ajattele niin. Anteeksi että ihastuin suhun varattuna. Pettänyt en ole koskaan ketään vaikka hu
      Ikävä
      100
      1074

    8. Reeniähororeeniä

      Helvetillisen vaikeaa työskennellä hoitajana,kun ei kestä silmissään yhtään läskiä. Saati hoitaa sellaista. Mitä tehdä?
      Kouvola
      7
      996

    9. Tarvitsemme lisää maahanmuuttoa.

      Väestö eläköityy, eli tarvitsemme lisää tekeviä käsiä ja veronmaksajia. Ainut ratkaisu löytyy maahanmuutosta. Nimenomaan
      Maailman menoa
      251
      954

    10. Kävit nainen näemmä mun

      Facessa katsomassa....
      Ikävä
      41
      929
    Aihe
    TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt