vba newb problem

AHKpie · #1 06-28-2017, 01:33 AM

Hello dear VBA programmers,

If I execute the next Macro1 in the document I am working in, I get the index I want printed in the same document.
What codes do I have to add if I want to select and copy only the index?

(The printed index is good but I want paste the result in a new empty document)
Many thanks in advance.

Sub Macro1()
ActiveDocument.TablesOfContents.Add Range:=Selection.Range, _
RightAlignPageNumbers:=True, _
UseHeadingStyles:=True, _
UpperHeadingLevel:=1, _
LowerHeadingLevel:=5, _
IncludePageNumbers:=True, _
AddedStyles:="", _
UseHyperlinks:=True, _
HidePageNumbersInWeb:=True, _
UseOutlineLevels:=True
End Sub

gmayor · #2 06-28-2017, 04:23 AM

The following should work

Code:

Sub Macro2()
    With ActiveDocument
        'insert the TOC
        .TablesOfContents.Add _
                Range:=Selection.Range, _
                RightAlignPageNumbers:=True, _
                UseHeadingStyles:=True, _
                UpperHeadingLevel:=1, _
                LowerHeadingLevel:=5, _
                IncludePageNumbers:=True, _
                AddedStyles:="", _
                UseHyperlinks:=True, _
                HidePageNumbersInWeb:=True, _
                UseOutlineLevels:=True
        'select the TOC
        .TablesOfContents.Item(1).Range.Select
        'Unlink the TOC field
        Selection.Fields.Unlink
        'Copy the unlinked TOC
        Selection.Copy
        'Undo the unlinking to restore the TOC field
        ActiveDocument.Undo 1
        'Next line is optional
        '.TablesOfContents.Item(1).Range.Delete
    End With
    MsgBox "TOC Copied to clipboard"
End Sub

AHKpie · #3 06-28-2017, 04:40 AM

Thank you very much Gmayor!

The script works perfectly and now I think I understand VBA code a little bit better thanks to your comment attached!

Have a nice day Gmayor!!

AHKpie · #4 07-03-2017, 11:29 PM

Dear programmers,

I found a very nice script developed bij Macropod (I named that macro OneFolderbatch). That script can execute find and replace function (see Macro12) in every document in One selected folder.
If I execute Macro2 manually (while that document opened) it works as I want but if I Call it in Onefolderbatch Macro2 or Macro3, I dont get the result of Macro2.
What codes do i have to change and add to my Macro2 or Macro3 so it works with OneFolderbatch?

Many many thanks in advance!

Code:

Sub OneFolderbatch()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  'Next line you can adapt the Macro to be executed for every document in a single folder
  Call Macro12(wdDoc)
  With wdDoc
    .SaveAs2 FileName:=strFolder & "\" & Split(strFile, ".")(0) & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
    .Close SaveChanges:=False
  End With
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
 
Sub Macro2()
    With ActiveDocument
        'insert the TOC
        .TablesOfContents.Add _
                Range:=Selection.Range, _
                RightAlignPageNumbers:=True, _
                UseHeadingStyles:=True, _
                UpperHeadingLevel:=1, _
                LowerHeadingLevel:=5, _
                IncludePageNumbers:=True, _
                AddedStyles:="", _
                UseHyperlinks:=True, _
                HidePageNumbersInWeb:=True, _
                UseOutlineLevels:=True
        'select the TOC
        .TablesOfContents.Item(1).Range.Select
        ''Unlink the TOC field
        'Selection.Fields.Unlink
        'Copy the unlinked TOC
        Selection.Copy
        'Undo the unlinking to restore the TOC field
        ActiveDocument.Undo 1
        'Next line is optional
        '.TablesOfContents.Item(1).Range.Delete
        Selection.WholeStory
        Selection.Delete Unit:=wdCharacter, Count:=1
        Selection.PasteAndFormat (wdFormatOriginalFormatting)
    End With
    
End Sub

Sub Macro3(wdDoc As Document)
  With wdDoc
    With ActiveDocument
        'insert the TOC
        .TablesOfContents.Add _
                Range:=Selection.Range, _
                RightAlignPageNumbers:=True, _
                UseHeadingStyles:=True, _
                UpperHeadingLevel:=1, _
                LowerHeadingLevel:=5, _
                IncludePageNumbers:=True, _
                AddedStyles:="", _
                UseHyperlinks:=True, _
                HidePageNumbersInWeb:=True, _
                UseOutlineLevels:=True
        'select the TOC
        .TablesOfContents.Item(1).Range.Select
        ''Unlink the TOC field
        'Selection.Fields.Unlink
        'Copy the unlinked TOC
        Selection.Copy
        'Undo the unlinking to restore the TOC field
        ActiveDocument.Undo 1
        'Next line is optional
        '.TablesOfContents.Item(1).Range.Delete
        Selection.WholeStory
        Selection.Delete Unit:=wdCharacter, Count:=1
        Selection.PasteAndFormat (wdFormatOriginalFormatting)
    End With
  End With
End Sub

Sub Macro12(wdDoc As Document)
'
' Macro12 Macro
'
'
  With wdDoc
    With .Range.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Text = "a"
      .Replacement.Text = "BBBBB"
      .Execute Replace:=wdReplaceAll
    End With
  End With
End Sub

AHKpie · #5 07-06-2017, 02:34 AM

Respectable programmers,

I think I have found the solution.
How nice software programming is if you understand what you are doing. Or at least if you think you understand what you are doing.

Have a nice day and thank you for reading my posts.

AHKpie · #6 07-07-2017, 07:07 AM

I solved my problem of not working macro by simplyfing Paul Edsteins script into this:

Code:

Sub Simplify()
Dim file
Dim path As String


'YOU MUST EDIT THIS. Put here the files you want to change with your macro.
path = "c:\test\"


file = Dir(path & "*.*")
Do While file <> ""
Documents.Open FileName:=path & file

' This is the call to the macro you want to run on each file in the folder
Call Macro2

' Saves the file
ActiveDocument.Save
ActiveDocument.Close
' set file to next in Dir
file = Dir()
Loop
End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Newb needing VBA solution to change formatting	derekcentrico	Word VBA	10	12-12-2016 12:27 PM
newb - search and replace - WILDCARDS - keep original...?	Bansaw	Word	4	09-01-2016 11:16 AM
Backing up importing & exporting ?? I am a newb	Jazz	OneNote	0	01-27-2016 10:18 PM
newb - need help automating catalogue production	Deeper	Office	2	09-09-2015 01:45 AM
NEWB to Macros - formatting exports	EC37	Excel Programming	52	06-25-2014 06:26 AM