#1
|
|||
|
|||
Copy/Paste/Delete Table & Section etc.
Hi,
I am working on documents that need to perform actions as copy, paste and delete. I am working on Documents that contain Tables, Appendices and off course Sections that I need to move (delete) to New Documents or Excel. The purpose is to copy complete documents to a software TcSE. I have over 500 documents to work on. This is what I need to do on all documents. - Break all hyper links in document - Replace all non-breaking hyphens with regular hyphens - Move (delete) tables (move them to excel, including title) - Move (delete) all “Reference Numbers” in Reference Section (move to excel, including title and carrige return) - Move (delete) all "Appendices" in Appendix Section. (move to new doc. , including title) - Remove all section breaks Note: there are some documents that are formatted and some unformatted. I don’t need to update the TOC, so the numbering will remain as is. I was wondering if all the above could be performed through a Macro, this would save me time and stress. I would appreciate if someone could help. Thanks FLDS |
#2
|
||||
|
||||
Hi flds,
Technically, yes, what you've described could be done with a macro. Some of what you're asking is quite simple, but other parts are quite complex. Overall it could require hours/days of coding effort. Some of what you're asking can also have adverse implications for your document layout (eg deleting Section breaks, especially if there's a mix or portrait and landscape Sections, or Sections with different numbers of columns).
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
Hello P. Edstein,
Thank you so much for your reply. Most of the documents are portrait and say few documents may have columns specially in the appendix sections. If I come across such situation I could do these sections manually or do the whole document manually. I have found a few of the macros on the web, I do not know how to put them together in one macro. I would like to combine these macros into one macro, is it too much to do? Paul, the Reference section is the second last section in the document. This is a string with bullets. the Appendix section is the last section in all documents, it starts as “Appendix ‘A’ “ and so on. The tables need to be copied first and then deleted. The macro “CopyTablesIntoNewDocument()” works on some documents and does not work on some, can this be fixed. The document does not need formatting. I tried deleting the TOC it does not delete. I hope you could combine all these macros into one. If possible to add a section delete macro. Appreciate your time and effort. Thanks again. FLDS Macros: Code:
Sub HyperlinkDelete() Dim i As Long For i = ActiveDocument.Hyperlinks.Count To 1 Step -1 ActiveDocument.Hyperlinks(i).Delete Next i End Sub Code:
Sub DeleteSectionBreaks() With ActiveDocument.Content.Find .ClearFormatting .Text = "^b" With .Replacement .ClearFormatting .Text = "" End With .Execute Replace:=wdReplaceAll End With End Sub Code:
Sub ReplaceNonBreakingHyphen() With ActiveDocument.Content.Find .ClearFormatting .Text = "^~" With .Replacement .ClearFormatting .Text = "^-" End With .Execute Replace:=wdReplaceAll End With End Sub Code:
Sub DeleteAllTables() Dim oTable As Table For Each oTable In ActiveDocument.Tables oTable.Delete Next oTable End Sub Code:
Sub SectionDelete() Dim TOC As TableOfContents Set TOC = ActiveDocument.TablesOfContents(1) With ActiveDocument .Sections(2).Range.Delete TOC.Update End With End Sub Code:
Sub CopyTablesIntoNewDocument() ' version 1.0 ' http://www.pdfhacks.com/copytables/ Dim SrcDoc, NewDoc As Document Dim SrcDocTableRange As Range Set SrcDoc = ActiveDocument If SrcDoc.Tables.Count <> 0 Then Set NewDoc = Documents.Add(DocumentType:=wdNewBlankDocument) Set NewDocRange = NewDoc.Range Dim PrevPara As Range Dim NextPara As Range Dim NextEnd As Long NextEnd = 0 For Each SrcDocTable In SrcDoc.Tables Set SrcDocTableRange = SrcDocTable.Range 'output the preceding paragraph? Set PrevPara = SrcDocTableRange.Previous(wdParagraph, 1) If PrevPara Is Nothing Or PrevPara.Start < NextEnd Then Else Set PPWords = PrevPara.Words If PPWords.Count > 1 Then 'yes NewDocRange.Start = NewDocRange.End NewDocRange.InsertParagraphBefore NewDocRange.Start = NewDocRange.End NewDocRange.InsertParagraphBefore NewDocRange.FormattedText = PrevPara.FormattedText End If End If 'output the table NewDocRange.Start = NewDocRange.End NewDocRange.FormattedText = SrcDocTableRange.FormattedText 'output the following paragraph? Set NextPara = SrcDocTableRange.Next(wdParagraph, 1) If NextPara Is Nothing Then Else Set PPWords = NextPara.Words NextEnd = NextPara.End If PPWords.Count > 1 Then 'yes NewDocRange.Start = NewDocRange.End NewDocRange.InsertParagraphBefore NewDocRange.FormattedText = NextPara.FormattedText End If End If Next SrcDocTable End If End Sub Last edited by macropod; 06-07-2011 at 09:09 PM. Reason: Added code structure and tags |
#4
|
||||
|
||||
Hi flds,
Try: Code:
Sub Main() Dim TOC As TableOfContents With ActiveDocument For Each TOC In .TablesOfContents TOC.Delete Next .Fields.Unlink Call MoveTablesToNewDocument With .Content.Find .ClearFormatting .Replacement.ClearFormatting .Text = "^b" .Replacement.Text = "" .Execute Replace:=wdReplaceAll .Text = "^~" .Replacement.Text = "-" .Execute Replace:=wdReplaceAll End With End With End Sub Code:
Sub MoveTablesToNewDocument() Dim SrcDoc, NewDoc As Document Dim SrcDocTableRange As Range Set SrcDoc = ActiveDocument If SrcDoc.Tables.Count <> 0 Then Set NewDoc = Documents.Add(DocumentType:=wdNewBlankDocument) Set NewDocRange = NewDoc.Range Dim PrevPara As Range Dim NextPara As Range Dim NextEnd As Long NextEnd = 0 With NewDocRange For Each SrcDocTable In SrcDoc.Tables Set SrcDocTableRange = SrcDocTable.Range 'output the preceding paragraph? Set PrevPara = SrcDocTableRange.Previous(wdParagraph, 1) If PrevPara Is Nothing Or PrevPara.Start < NextEnd Then Else Set PPWords = PrevPara.Words If PPWords.Count > 1 Then 'yes .Start = NewDocRange.End .InsertParagraphBefore .Start = NewDocRange.End .InsertParagraphBefore .FormattedText = PrevPara.FormattedText End If End If 'output the table .Start = .End .FormattedText = SrcDocTableRange.FormattedText 'output the following paragraph? Set NextPara = SrcDocTableRange.Next(wdParagraph, 1) If NextPara Is Nothing Then Else Set PPWords = NextPara.Words NextEnd = NextPara.End If PPWords.Count > 1 Then 'yes .Start = .End .InsertParagraphBefore .FormattedText = NextPara.FormattedText End If End If SrcDocTableRange.Delete Next SrcDocTable End With End If End Sub
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] Last edited by macropod; 06-08-2011 at 09:55 PM. Reason: Minor code revision - TOC variable and loop in 1st module |
#5
|
|||
|
|||
Hi Paul,
Thanks for your help. I will try this code and get back to you. I see that you could not add a code to move the Sections "Reference" and Appendix. Thanks for your time. FLDS |
#6
|
||||
|
||||
Hi flds,
It's not so much that I can't, but I don't have the time - I'm studying for uni exams right now.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#7
|
|||
|
|||
Hi Paul,
Thanks for your reply. Sorry to have taken your time. I wish you all the best for your exams. I did try the code this morning. As promised this is the feedback. One document 1 runs well but other document 2, I get an error message. When I run the code I get this error message, it stops at “Call MoveTablesToNewDocument” In Code Main Document 1 VBA error message Run time error ‘91’: Object variable or with block variable not set. When I debug, I see line 17 highlighted “If prevPar Is Nothing Or PrevPara .Start < NextEnd Then” In Code “MoveTablesToNewDocument()”. Document 2 This document that runs the code ok. I see the text moved but the table grid still exists as empty. Please give priority to your studies. Thanks FLDS |
#8
|
||||
|
||||
Hi flds,
I've tested the code. The error occurs when the source document has nothing before the first table. Please note that I only made the minimum changes necessary to integrate the code with what you asked for. Reworking the code to handle these conditions correctly will take a small amount of effort - but not today. On reviewing the code I also found that (aside from the fact that it moves the tables to a new Word document instead of to an Excel workbook) a number of variables weren't defined and the code copies the paragraph following the table to the new document as well. Is that what you wanted? As for moving Word tables to Excel, whilst that's not all that difficult to do in principle, retaining the formatting gets complicated, especially if the Word table has merged cells. As for the 'Appendix' Section you referred to, do all documents have one? Do the appendices only ever span one Section? Whatever the case, it would probably make sense to process the appendices before deleting the Section breaks. I've also updated the 'Main' sub to handle documents that may have 0 and >1 TablesOfContents. Finally, contrary to what I had expected to happen, the code isn't deleting the tables in the source document. It will do so if you change: SrcDocTableRange.Delete to: SrcDocTable.Delete
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#9
|
|||
|
|||
Thanks Paul,
I will try and get back to you. Do what ever you can, please do not go out of the way. Where is the updated 'Main' sub. "I've also updated the 'Main' sub to handle documents that may have 0 and >1 TablesOfContents. Finally, contrary to what I had expected to happen, the code isn't deleting the tables in the source document. It will do so if you change:" Formatting is not necessary not required. "retaining the formatting gets complicated" I need only the tables only. dont bother about moving it to excel, I will request it another time. I will work on all the 500 or so document first with what code I have. "On reviewing the code I also found that (aside from the fact that it moves the tables to a new Word document instead of to an Excel workbook) a number of variables weren't defined and the code copies the paragraph following the table to the new document as well. Is that what you wanted?" All the best FLDS |
#10
|
||||
|
||||
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#11
|
|||
|
|||
Hi Paul,
I am still getting error messages when it runs "MoveTablesToNewDocument()". Dont bother right now, just concentrate on your exams. I will work on other stuff in the meantime, like cleaning all document with the "main" code. when I am ready to transfer the doc. to TcSE I will get back to you. Is it ok with you, if I try with other forums with questions. Thanks FLDS |
#12
|
||||
|
||||
Hi flds,
Posting in other forums is fine. If you do, please provide them with a link to this one and vice versa. That way, posters in both forums will have the benefit of being able to see what others have contributed and won't waste time re-inventing the wheel.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#13
|
||||
|
||||
Hi flds,
You might find things work best if you make 3 copies of each document, keeping just the text for the 1st, the tables for the 2nd and the appendices for the 3rd. Deleting tables or non-table paragraphs is quite simple, as is deleting/retaining appendix/non-appendix Sections.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#14
|
|||
|
|||
Hi Paul,
Thanks for your reply. How are your studies going on, by the way when are your exams. This is what I was doing, I separated the text, tables and appendix in each doc (3 docs). This I been doing manually and it takes a lot of time doing each doc. This is the reason I was looking for a macro to do this all for me. I have no intentions to go to other forums, it was just a question. Before I joined MSO forum, I had posted this in "Tech Support Forum" I did not get any reply even though 93 viewed my requirements. Thanks and all the best. FLDS |
#15
|
||||
|
||||
Hi flds,
Try the following: Code:
Sub ParseDocs() Application.ScreenUpdating = False Dim strInFold As String, strOutFold As String, strFile As String, strOutFile As String Dim TOC As TableOfContents, Para As Paragraph, Tbl As Table, Sctn As Section, Rng As Range Dim DocSrc As Document, DocTxt As Document, DocTbl As Document, DocApp As Document strInFold = GetFolder If strInFold = "" Then Exit Sub strFile = Dir(strInFold & "\*.doc", vbNormal) If strFile <> "" Then strOutFold = strInFold & "\Output" If Dir(strOutFold, vbDirectory) = "" Then MkDir strOutFold strFile = Dir(strInFold & "\*.doc", vbNormal) While strFile <> "" Set DocSrc = Documents.Open(FileName:=strInFold & "\" & strFile, AddTorecentFiles:=False, Visible:=False) With DocSrc For Each TOC In .TablesOfContents TOC.Delete Next .Fields.Unlink If .Tables.Count > 0 Then .Range.Copy Set DocTbl = Documents.Add(Visible:=False) With DocTbl .Range.Paste For Each Para In .Paragraphs With Para.Range On Error Resume Next If .Information(wdWithInTable) = False Then If .Next.Paragraphs.First.Range.Information(wdWithInTable) = False Then .Delete Else .Text = vbCr End If End If End With Next Call Cleanup(.Range) End With For Each Tbl In .Tables Tbl.Delete Next For Each Sctn In .Sections If UCase(Sctn.Range.Words.First) = "APPENDIX" Then Set Rng = Sctn.Range Rng.End = .Range.End Rng.Cut Set DocApp = Documents.Add(Visible:=False) With DocApp .Range.Paste Call Cleanup(.Range) End With Exit For End If Next Call Cleanup(.Range) End If strOutFile = strOutFold & "\" & Split(.Name, ".")(0) .Range.Copy Set DocTxt = Documents.Add(Visible:=False) With DocTxt .Range.Paste .SaveAs FileName:=strOutFile & "-Text", AddTorecentFiles:=False .Close End With Set DocTxt = Nothing If Not DocTbl Is Nothing Then DocTbl.SaveAs FileName:=strOutFile & "-Tables", AddTorecentFiles:=False DocTbl.Close Set DocTbl = Nothing End If If Not DocApp Is Nothing Then DocApp.SaveAs FileName:=strOutFile & "-Appendices", AddTorecentFiles:=False DocApp.Close Set DocApp = Nothing End If .Close SaveChanges:=False End With strFile = Dir() Wend Set DocSrc = Nothing Application.ScreenUpdating = True End Sub Function GetFolder(Optional Title As String, Optional RootFolder As Variant) As String On Error Resume Next GetFolder = CreateObject("Shell.Application").BrowseForFolder(0, Title, 0, RootFolder).Items.Item.Path End Function Sub Cleanup(Rng As Range) With Rng.Find .ClearFormatting .Replacement.ClearFormatting .Text = "^b" .Replacement.Text = "" .Execute Replace:=wdReplaceAll .Text = "^~" .Replacement.Text = "-" .Execute Replace:=wdReplaceAll End With End Sub The code includes folder navigation and code to produce an 'Output' folder below that for holding the output files. All documents in the selected folder will be processed automatically.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
copy and paste not working | Ellie | Word | 3 | 11-07-2013 02:23 PM |
Can't copy paste | irenasobolewska | Office | 2 | 10-26-2012 05:09 PM |
Copy - Paste between 2 tables | rod147 | Excel | 1 | 10-22-2009 08:21 PM |
Copy & paste low resolution | worriedme | Drawing and Graphics | 0 | 06-01-2009 03:05 AM |
Copy and paste special | Dace | Excel | 2 | 02-16-2009 12:18 PM |