vba - Copy and paste rows from Excel to Powerpoint -
ok, here looking (im new, gentle):
- copy , paste (default format) excel powerpoint (from 1 sheet)
- i can fit many rows in ppt - after slide fills, want ppt create new slide
- same title each slide fine!
- i need columns b:k copied over
that's it, stuck :( know below code not best way write , contains errors in sure easy spot. cannot find how anywhere on net.
this have far:
sub excelrangetopowerpoint() dim rng excel.range dim powerpointapp powerpoint.application dim mypresentation powerpoint.presentation dim myslide powerpoint.slide dim myshaperange powerpoint.shape dim integer 'create instance of powerpoint on error resume next 'is powerpoint opened? set powerpointapp = getobject(class:="powerpoint.application") 'clear error between errors err.clear 'if powerpoint not open open powerpoint if powerpointapp nothing set powerpointapp = createobject(class:="powerpoint.application") 'make powerpoint visible , active powerpointapp.visible = true powerpointapp.activate 'create new presentation set mypresentation = powerpointapp.presentations.add 'add slide presentation set myslide = mypresentation.slides.add(1, pplayouttitleonly) = 1 6 'need set focus slde 1 powerpointapp.activewindow.view.gotoslide (1) 'deletes title 'myslide.shapes.title.delete 'builds new title myslide.shapes.addshape type:=msoshaperectangle, left:=9, top:=6, width:=702, height:=30 myslide.shapes(myslide.shapes.count).line.visible = msotrue myslide.shapes(myslide.shapes.count).textframe.textrange.font.size = 20 myslide.shapes(myslide.shapes.count).textframe.textrange.font.color.rgb = rgb(0, 0, 0) myslide.shapes(myslide.shapes.count).textframe.textrange.paragraphformat.alignment = ppalignleft myslide.shapes(myslide.shapes.count).textframe.textrange.text = "current full initiative details – branded book of " & date myslide.shapes(myslide.shapes.count).name = "i title" myslide.shapes(myslide.shapes.count).line.forecolor.rgb = rgb(0, 0, 0) myslide.shapes(myslide.shapes.count).line.weight = 1 myslide.shapes(myslide.shapes.count).fill.visible = msotrue myslide.shapes(myslide.shapes.count).fill.forecolor.rgb = rgb(255, 255, 255) 'copy range excel set rng = activeworkbook.worksheets("raw").range("b1:k23") 'copy excel range rng.copy 'paste powerpoint , position powerpointapp.activewindow.view.pastespecial datatype:=pppastedefault set myshaperange = myslide.shapes(myslide.shapes.count) 'set position: myshaperange.left = 10 myshaperange.top = 42 myshaperange.height = 492 myshaperange.width = 702 activeworkbook.sheets("raw").rows("2:23").delete call mypresentation.slides.add(1, ppslidelayout.pplayouttitleonly) 'clear clipboard application.cutcopymode = false next end sub
as requested in comments, here code use copy slide master ppt template report ppt.
there extraneous code in there provide status updates on form use drive process, debugging flag can toggle on/off @ run time - these can both removed.
this serve starting point finding proper solution situation, , not complete answer question asked.
'i've chosen declare these globally, though it's not best way: dim pptobj powerpoint.application dim pptmaster powerpoint.presentation dim pptclinic powerpoint.presentation private sub insertppt(byval slidename string, byval statustext string) dim shp powerpoint.shape dim top single dim left single dim height single dim width single pptmaster.slides(slidename).copy pptclinic.slides.paste form_master.processstatus.value = statustext & " insertppt" pptclinic.slides(pptclinic.slides.count) if debugging .select end if .design = pptmaster.slides(slidename).design 'this ensures right formatting - seems necessary 1 time, we'll on .colorscheme = pptmaster.slides(slidename).colorscheme .followmasterbackground = pptmaster.slides(slidename).followmasterbackground each shp in .shapes 'loop through shapes on slide if debugging ' .select shp.select end if form_master.processstatus.value = statustext & " insertppt-" & shp.name if shp.type = msolinkedoleobject 'when find linked 1 relinkshape shp, tempvars!newxlname 'need store off top, left, width, height top = shp.top left = shp.left height = shp.height width = shp.width shp.linkformat.update 'and force link refresh mysleep 2, "s" 'hopefully, 2 second pause allow update before moving on. 'then reset them here - seem change shape when update them shp.lockaspectratio = msofalse shp.top = top shp.left = left shp.width = width shp.height = height elseif shp.name = "slidename" , not debugging 'if it's "slidename" tag shp.delete 'delete (unless we're debugging) end if next end form_master.processstatus.value = statustext end sub private sub relinkshape(byref shp powerpoint.shape, byval newdestination string) dim link() string dim link2() string if shp.type = msolinkedoleobject 'when find linked 1 link = split(shp.linkformat.sourcefullname, "!") 'update link point new clinic spreadsheet instead of master if instr(1, link(2), "]") > 0 link2 = split(link(2), "]") link(2) = "[" & tempvars!clinicname & ".xlsx]" & link2(1) end if shp.linkformat.sourcefullname = newdestination & "!" & link(1) & "!" & link(2) end if end sub public sub mysleep(byref unit double, byref uom string) dim pause date pause = dateadd(uom, unit, now()) while < pause doevents wend end sub
Comments
Post a Comment