Productpresentatie in Powerpoint genereren vanuit Excel?

Status
Niet open voor verdere reacties.
Thanks, zoals ik al in mijn eerste vraag had aangegeven:
...Mijn VBA kennis zit op beginnersniveau, dus alleen eenvoudige wijzigingen kan ik zelf aanbrengen. ...
Klik om te vergroten...

Ik ga hem testen!
 
Ik krijg hem niet aan de praat, hij blijft toch hangen op de sn.

Kan je hem aub in zijn geheel eens posten? Dan kan ik zien wat ik fout doe (en dan leren we weer wat!):thumb:
 
Ik kan jouw Excelbetand van hieraf net niet zien.....
Plaats die eerst eens hier.

Waarschijnlijk: verander sheet1. in Blad1.
 
Laatst bewerkt:
Blad1 deed het in dit geval goed, maar ik krijg nog altijd geen tekst in de PP en her en der foutmeldingen. Kan je de volledige code aub posten?
 
Dit is de volledige code.

Kun jij je Excelbestand svp plaatsen ?
 
Ha, nu begrijp ik je opmerking:
Als ik moet aangeven waar je deze macro moet invoegen kun je beter eerst eens een basisboek over VBA bestuderen.
Klik om te vergroten...

Mijn vraag was blijkbaar niet duidelijk. Waar binnen de code en in plaats van welke code moet ik dit invoegen?
Bijgaand hoe het nu staat.
Code: 
Sub newPowerPoint()
'Microsoft PowerPoint Library toevoegen via:
    '1. Extra in het VBA menu, Verwijzingen
    '3. Zoek Microsoft PowerPoint X.0 Object Library op, check het vinkje, en druk op OK
'Variabelen declareren
Dim nwPP As PowerPoint.Application
Dim aSlide As PowerPoint.Slide
Dim oPic As Object
Dim i As Integer
Dim rng As Range
Dim arr As Variant
Dim obj As Object
    
    'Tabel in een array zetten
    Set rng = ActiveSheet.Cells(1).CurrentRegion
    arr = rng
    
    'Kijken of PowerPoint al open is
    On Error Resume Next
    Set nwPP = GetObject(, "PowerPoint.Application")
    On Error GoTo 0
    
    'Zo niet: nieuwe maken!
    If nwPP Is Nothing Then Set nwPP = New PowerPoint.Application
    'En dan een nieuwe presentatie maken, of de bestaande gebruiken
    With nwPP
        If .Presentations.Count = 0 Then .Presentations.Add
        'La ma zien...
        .Visible = True
    End With
    
    sn = Blad1.Cells(1).CurrentRegion
    
    With GetObject(, "PowerPoint.Application")
        With .ActivePresentation
            For j = 1 To UBound(sn)
                With .Slides.Add(j, 12)
                    .Shapes.AddPicture sn(j, 1), True, False, 20, 20, 400, 400
                    .Shapes.AddTextbox(1, 5, 450, 400, 50).TextEffect.Text = sn(j, 3)
                End With
            Next
        End With
    End With
End Sub
 
Gooi die hele code weg.
Gebruik alleen de mijne.

En nog heb je geen bestand geplaatst. Leesproblemen ?
 
Laatst bewerkt:
snb zei:
En nog heb je geen bestand geplaatst. Leesproblemen ?
Klik om te vergroten...
Kijk eens in het derde bericht... En bedenk dan wie er leesproblemen heeft ;)
 
@octa

Zijn daarin de wijzigingen aangebracht die jij gesuggereerd hebt ? de volledige namen van de afbeeldingen ???
De code loopt natuurlijk alleen maar goed als de gegevens voor de bestandsnaam en voor het bijschrift in de met de code overeenkomende kolommen staan.
 
Nee, maar ik had ze zelf al gemaakt :).
 
Het gaat eer niet om of het in jouw bestand goed loopt, maar in het -aangepaste- bestand van de vragensteller.
Daarom vraag ik naar het bestand waarin hij de code aan het testen is.
 
Bekijk bijlage voorbeeld.xlsx

Bijgaand het bestand
@snb:
Bij de code die ik van jou heb, moet PP al geopend zijn. Het zou fijn zijn als PP geopend wordt indien nog niet open.
Daarnaast geeft hij bij
Code: 
.Shapes.AddPicture sn(j, 1), True, False, 20, 20, 400, 400
de foutmelding: "Het opgegeven bestand is niet gevonden"
Verder heb ik totaal geen leesproblemen :shocked:
 
Code: 
Sub M_snb()
    sn = Blad1.Cells(1).CurrentRegion
    
    With createobject("PowerPoint.Application")
        With .Presentations.Add
            For j = 2 To UBound(sn)
                With .Slides.Add(j, 12)
                    .Shapes.AddPicture sn(j, 1), True, False, 20, 20, 400, 400
                    .Shapes.AddTextbox(1, 5, 450, 400, 50).TextEffect.Text = sn(j, 3)
                End With
            Next
        End With

        .Visible = True
    End With
End Sub

Of de bestandnamen kloppen in kolom A kan ik niet beoordelen.
Gebruik per ongeluk ook eens F8 om stapsgewijs door de code te lopen en te constateren welke waarden bepaalde variabelen hebben.
 
Laatst bewerkt:
Code: 
Sub M_snb()
    sn = Blad1.Cells(1).CurrentRegion
    
    With createobject("PowerPoint.Application")
        With .Presentations.Add
            For j = 2 To UBound(sn)
                With .Slides.Add(j-1, 12)
                    .Shapes.AddPicture sn(j, 1), True, False, 20, 20, 400, 400
                    .Shapes.AddTextbox(1, 5, 450, 400, 50).TextEffect.Text = sn(j, 3)
                End With
            Next
        End With

        .Visible = True
    End With
End Sub
 
Hij werkte fantastisch!
Alleen heb ik er nog wat kolommen aan toegevoegd om de aanvullende teksten ook toe te kunnen voegen. Nu loopt hij vast op
Code: 
   For j = 2 To UBound(sn)

Hij geeft daarbij aan: "Typen komen niet met elkaar overeen.

Onderstaand de gehele code zoals ik hem nu heb:
Code: 
Sub Powerpoint_maken()

Call Afbeelding_invoegen                                                             'MACRO OUTPUT GEEFT ZOALS VOORBEELD BESTAND

    Dim lastRow As Long
    lastRow = Range("B" & Rows.Count).End(xlUp).Row
    
    Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("B:B").Font.ThemeColor = xlThemeColorLight1
    With Range("B2")
        .FormulaR1C1 = "=RC[1]&" - "&RC[2]"                                                             'SAMENVOEGEN ARTIKELNUMMER EN ARTIKELNAAM
        .AutoFill Destination:=Range("B2:B" & lastRow)
    End With
    
    Columns("E:E").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    With Range("E2")
        .FormulaR1C1 = "=RC[1]&CHAR(10)&RC[2]&CHAR(10)&RC[3]&CHAR(10)&RC[4]&CHAR(10)&RC[5]&CHAR(10)&RC[6]"          'SAMENVOEGEN SPECIFICATIES ARTIKELEN
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = True
        .AutoFill Destination:=Range("E2:E" & lastRow)
    End With
    
    Range("B1,E1").Value = "temp"
    
'ORIGINELE CODE
    sn = Blad1.Cells(1).CurrentRegion
    
    With CreateObject("PowerPoint.Application")
        With .Presentations.Add
            For j = 2 To UBound(sn)
                With .Slides.Add(j - 1, 12)
                     .Shapes.AddPicture sn(j, 1), True, False, 20, 20, 400, 400
                     .Shapes.AddTextbox(1, 5, 450, 400, 50).TextEffect.Text = sn(j, 3)                         'TEKSTVAK ARTIKELNUMMER EN ARTIKELNAAM
                     .Shapes.AddTextbox(1, 5, 450, 400, 50).TextEffect.Text = sn(j, 5)                         'TEKSTVAK ARTIKELSPECIFICATIES
                End With
            Next
        End With

        .Visible = True
    End With
End Sub

Ik vermoed als deze bug gefixt is, dat alles als een zonnetje loopt. Ik zal dan alleen de positie van de tekstvakken nog aan hoeven passen

Dank voor jullie hulp!
 
Mij lijkt Call afbeelding_invoegen niet meer van toeapssing.
Sowieso gebruiken we sinds Office 97 'Call' niet meer.

Als je een werkende code hebt voor een bepaald werkblad, moet je aan de struktuur van het werkblad niets meer wijzigen.
Je hebt onder rij 1 van Blad1 een lege rij ingevoegd. Niet slim.

gebruik

Code: 
    Blad1.Columns(2).Insert
    Blad1.Columns(2).Font.ThemeColor = xlThemeColorLight1
    [Blad1!B2:B400]=[if(A2:A400="","",A2:A400&"-"&C2:C400)]

in plaats van:
Code: 
Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("B:B").Font.ThemeColor = xlThemeColorLight1
    With Range("B2")
        .FormulaR1C1 = "=RC[1]&" - "&RC[2]"                                                             'SAMENVOEGEN ARTIKELNUMMER EN ARTIKELNAAM
        .AutoFill Destination:=Range("B2:B" & lastRow)
    End With

In kolom E heb je een verwijzing naar de kolom zelf ingevoerd. Houdt Excel niet van.

Gebruik ook hier:

Code: 
[Blad1!E2:E400]=[if(A2:A400="","",A2:A400&char(10)&B2:B400&char(10)&C2:C400&char(10)&D2:D400&char(10)&F2:F400)]
 
Laatst bewerkt:
Mij lijkt Call afbeelding_invoegen niet meer van toeapssing.
Sowieso gebruiken we sinds Office 97 'Call' niet meer.
Klik om te vergroten...
De macro Afbeelding_invoegen is bedoeld om het basisbestand te creëeren. dit moet op zich wienig tot geen invloed hebben, aangezien het resultaat van die macro het basisbestand is zoals ik heb gepost.
Toch werkt 'Call' nog altijd prima...

Je hebt onder rij 1 van Blad1 een lege rij ingevoegd. Niet slim.
Klik om te vergroten...
Voor zover ik kan nagaan voeg ik nergens een rij in. Enige wijziging in opmaak zijn wat extra kolommen die geen invloed zouden moeten hebben op de PowerPoint code.

Hij blijft vastlopen dezelfde regel met dezelfde foutmelding...
Code: 
   For j = 2 To UBound(sn)

Bijgaand het bestand met code
Bekijk bijlage voorbeeld.xlsm
 
Vervang de volledige code door:

Code: 
Sub Powerpoint_maken()
    sn = Blad1.Cells(1).CurrentRegion
    
    With CreateObject("PowerPoint.Application")
        With .Presentations.Add
            For j = 2 To UBound(sn)
                With .Slides.Add(j - 1, 12)
                     .Shapes.AddPicture sn(j, 1), True, False, 20, 20, 400, 400
                     .Shapes.AddTextbox(1, 5, 450, 400, 50).TextEffect.Text = sn(j, 3) & " - " & sn(j, 4)
                     .Shapes.AddTextbox(1, 5, 450, 400, 50).TextEffect.Text = Join(Application.Index(sn, j), vbLf)
                End With
            Next
        End With

        .Visible = True
    End With
End Sub

Je hebt geen nieuwe kolommen nodig om de gegevens in de powerpointpresentatie in te voegen.
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan