[Help]Macro to Transfer Table Specific Content in MS Word 2007

i have around 50 word docs in old format need convert in new format thinking of having new format template , copying needed numbered fields old format in new format using macro , saving new document.
have numbered fields 1 6 in old format fields in header , need these fields in new format sequence different.

i dont know macros , need submit in next 2-3 days may have cross posted.
appreciate if me out.

thanks

old formathttp://www.scribd.com/r0ckyman/d/90470134-old-format

new format

http://www.scribd.com/r0ckyman/d/90473107-new-format

hi r0ckyman,

try following updatedocumentformats macro, put in empty document. point folder containing documents converted. after running, they'll in new format. you'll need change filespecs in doctgt variable point file new document format.

option explicit

sub updatedocumentformats()
application.screenupdating = false
dim docsrc document, doctgt document, rng range
dim strfolder string, strfile string
strfolder = getfolder
if strfolder = "" exit sub
set doctgt = documents.open(filename:="c:\users\r0cky\documents\r0cky new format.doc", addtorecentfiles:=false)
strfile = dir(strfolder & "\*.doc", vbnormal)
while strfile <> ""
  set docsrc = documents.open(filename:=strfolder & "\" & strfile, addtorecentfiles:=false, visible:=false)
  doctgt
  .sections.first.headers(wdheaderfooterprimary).range.tables(1)
    docsrc.sections.first.headers(wdheaderfooterprimary).range.tables(1).cell(1, 2).range.copy
    .cell(1, 2).range.paste
    docsrc.sections.first.headers(wdheaderfooterprimary).range.tables(1).cell(1, 4).range.copy
    .cell(1, 6).range.paste
  end with
  .tables(5)
    docsrc.sections.first.headers(wdheaderfooterprimary).range.tables(1).cell(2, 2).range.copy
    .cell(1, 2).range.paste
    set rng = docsrc.tables(3).cell(7, 1).range
    rng
      if instr(.text, "pre-requisites") > 0 then
        .end = .start + instr(.text, "pre-requisites") + len("pre-requisites")
      end if
      while .characters.last.next.text = " "
        .end = .end + 1
      wend
      .text = vbnullstring
    end with
    docsrc.tables(3).cell(7, 1).range.copy
    .cell(2, 2).range.paste
  end with
  .tables(1)
    docsrc.tables(1).cell(2, 2).range.copy
    .cell(2, 2).range.paste
    docsrc.tables(1).cell(2, 4).range.copy
    .cell(2, 6).range.paste
  end with
  docsrc.close savechanges:=false
  .saveas2 filename:=strfolder & "\" & strfile, addtorecentfiles:=false
  .close
end with
  strfile = dir()
wend
set docsrc = nothing: set doctgt = nothing
application.screenupdating = true
end sub

function getfolder() string
dim ofolder object
getfolder = ""
set ofolder = createobject("shell.application").browseforfolder(0, "choose folder", 0)
if (not ofolder nothing) getfolder = ofolder.items.item.path
set ofolder = nothing
end function

cross-posted at: http://www.techsupportforum.com/forums/f57/macro-to-transfer-table-content-in-ms-word-641210.html
cross-posting etiquette, please read: http://www.excelguru.ca/content.php?184

---

cheers
paul edstein
[ms mvp - word]

Microsoft Office  >  Word IT Pro Discussions