excel vba - Migrating Powerpoint information to Access database using VBA -

i interning large firm stores lot of source data in form of powerpoints. these powerppoints serve when communicating across departments , between suppliers but, may guess, lack robust analysis. because of this, have decided database these powerpoints access.

there no direct way of doing this, know of. due strict policies, limited vba coding platform. have spent last week coding macro solve problem. again, since there no direct conversion of powerpoint access, have had solve problem rather inefficiently there few caveats. list steps , caveats below.

1. the powerpoint information want database formatted table instead of text. have been unable find macro converts ppt tables directly excel or csv files. because of this, convert ppt files (roughly 3000) pdfs.

2. from these generated pdf's can use adobe convert them excel or csv files.

3. using multiple online resources , bit of own experience, have coded vba script automatically format folder of csv files format access store correctly. see code 1.

   • (the "personal.xlsb!module1.formataccess" macro created "record macro." omitted code due length , redundancy.)

4. after formatting csvs, automate them access.

5. following access automation, need embed each ppt file respective access entry

again, not efficient process. because limited microsoft applications, have chosen route. thought leaving information excel files, idea make data accessible , searchable department, hence why chose access database them.

now have explained coming , doing, ask: recommendations have me? feel round-about way solution , practical, wonder if there better solution.

code 1

sub loopcsvfile()  dim fso object  'scritping.filesystemobject dim fldr object 'scripting.folder dim file object 'scripting.file dim wb workbook  set fso = createobject("scripting.filesystemobject") set fldr = fso.getfolder("c:\users\hmm105289\documents\powerpoint parsing\test folder\test save folder")  each file in fldr.files      set wb = workbooks.open(file.path)      application.run "personal.xlsb!module1.formataccess"      wb.close savechanges = true  next  set file = nothing set fldr = nothing set fso = nothing 

end sub

edit 1

having played around of tim's suggestions, have come code run check on each ppt slide. idea have run "extracttable" macro inside. stands, unable execute.

sub pptablextraction()  dim oslide slide dim oslides slides dim oppt object: set oppt = activepresentation dim oshapes shape dim otable object    each oslide in oppt.slides     each oshapes in oslide.shapes         if oshapes.hastable             application.run "vbaproject.xlsb!module3.extracttablecontent"         end if     next next   end sub 

edit 2

i able build on tim's code create code loops each powerpoint file , extracts information excel. code doesn't break debugger whatever reason not performing functions. have idea why?

sub tester() dim ppts powerpoint.application  dim folderpath string dim filename string  folderpath = "folderpath" filename = dir(folderpath & "*.ppt*")  while filename <> ""     set ppts = new powerpoint.application     ppts.visible = true     ppts.presentations.open filename:=folderpath & filename     = cells.find("*", searchorder:=xlbyrows, searchdirection:=xlprevious).row + 5     b = "b" &     x = "a" &     range(x).value = "new"  dim ppt object, tbl object dim slide object, pres object, shp dim rngdest range       set ppt = getobject(, "powerpoint.application")      set pres = ppt.activepresentation      set rngdest = sheets("data").range(b) '      each slide in pres.slides         each shp in slide.shapes             if shp.hastable                 extracttablecontent shp.table, rngdest                 set rngdest = rngdest.offset(shp.table.rows.count + 3, 0)             end if         next     next      ppts.activepresentation.close     filename = dir loop end sub   sub extracttablecontent(otable object, rng range)     dim r, c, offr long, offc long      each r in otable.rows '<< loop on each row in ppt table          offc = 0 '<< reset column offset          each c in r.cells '<< loop on each cell in row              'copy cell's text content excel, using offsets             '    offr , offc select gets placed relative             '    starting point (rng)             rng.offset(offr, offc).value = c.shape.textframe.textrange.text              offc = offc + 1 '<< increment column offset          next c          offr = offr + 1 '<< increment row offset      next r  end sub  sub n() range("a3").value = "new" end sub 

here's example of extracting table ppt excel.

looping on slides , tables (modified posted code)

sub tester()      dim ppt object, tbl object     dim slide object, pres object, shp     dim rngdest range       set ppt = getobject(, "powerpoint.application")      set pres = ppt.activepresentation      set rngdest = sheets("data").range("a1") '<< start placing ppt data      each slide in pres.slides         each shp in slide.shapes             if shp.hastable                 extracttablecontent shp.table, rngdest                 set rngdest = rngdest.offset(shp.table.rows.count + 3, 0)             end if         next     next  end sub 

the sub extract each table's data:

sub extracttablecontent(otable object, rng range)     dim r, c, offr long, offc long      each r in otable.rows '<< loop on each row in ppt table          offc = 0 '<< reset column offset          each c in r.cells '<< loop on each cell in row              'copy cell's text content excel, using offsets             '    offr , offc select gets placed relative             '    starting point (rng)             rng.offset(offr, offc).value = c.shape.textframe.textrange.text              offc = offc + 1 '<< increment column offset          next c          offr = offr + 1 '<< increment row offset      next r end sub