I want to insert 2 column and one row in header using vba. I tried the following code but it works one time and gives the error 6028 (the range cannot be deleted) other time. Can any one suggest me any solution.
Sub UpdateHeader()
Dim oDoc As Word.Document, oSec As Word.Section, rng As Word.Range
Set oDoc = ActiveDocument
For Each oSec In oDoc.Sections
Set rng = oSec.Headers(Word.WdHeaderFooterIndex.wdHeaderFooterFirstPage).Range
AddHeaderToRange rng
Set rng = oSec.Headers(Word.WdHeaderFooterIndex.wdHeaderFooterPrimary).Range
AddHeaderToRange rng
Next oSec
End Sub
Private Sub AddHeaderToRange(rng As Word.Range)
With rng
.Tables.Add Range:=rng, NumRows:=1, NumColumns:=2
With .Tables(1)
.Borders.InsideLineStyle = wdLineStyleNone
.Borders.OutsideLineStyle = wdLineStyleNone
.Rows.SetLeftIndent LeftIndent:=-37, RulerStyle:=wdAdjustNone
.Columns(2).SetWidth ColumnWidth:=300, RulerStyle:=wdAdjustNone
.Cell(1, 1).Range.InlineShapes.AddPicture FileName:="Your Pic Solution", LinkToFile:=False, SaveWithDocument:=True
.Cell(1, 2).Range.Font.Name = "Arial"
.Cell(1, 2).Range.Font.Size = 9
.Cell(1, 2).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
.Cell(1, 2).Range.Text = "Test header" & vbNewLine & "Second Line"
End With
End With
End Sub
Try:
Sub UpdateHeaders()
Application.ScreenUpdating = False
Dim Tbl As Table, Sctn As Section
With ActiveDocument
Set Tbl = .Tables.Add(Range:=.Range(0, 0), NumRows:=1, NumColumns:=2)
With Tbl
.Borders.InsideLineStyle = wdLineStyleNone
.Borders.OutsideLineStyle = wdLineStyleNone
.Rows.SetLeftIndent LeftIndent:=-37, RulerStyle:=wdAdjustNone
.Columns(2).SetWidth ColumnWidth:=300, RulerStyle:=wdAdjustNone
.Cell(1, 1).Range.InlineShapes.AddPicture FileName:="Your Pic Solution", LinkToFile:=False, SaveWithDocument:=True
.Cell(1, 2).Range.Font.Name = "Arial"
.Cell(1, 2).Range.Font.Size = 9
.Cell(1, 2).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
.Cell(1, 2).Range.Text = "Test header" & vbCr & "Second Line"
End With
For Each Sctn In .Sections
With Sctn
With .Headers(wdHeaderFooterPrimary)
If .LinkToPrevious = False Then .Range.FormattedText = Tbl.Range.FormattedText
End With
With .Headers(wdHeaderFooterFirstPage)
If .LinkToPrevious = False Then .Range.FormattedText = Tbl.Range.FormattedText
End With
End With
Next
Tbl.Delete
End With
Application.ScreenUpdating = True
End Sub
Related
I am trying to make a vba code in word to automating of insertion of tabels when a checkbox is cheked (True). But I get different type of error, deppending on whether I use the Boolean varable Checkbox1 or the ContentControl varable Checkbox1 in the IF statement, see the code below.
I have many of these checkboxes, in my document, så when the user click and chose one (or more) checkboxes the program shall insert a table for that specific checkbox.
Sub CheckBox_Click()
'Dim CheckBox1 As Boolean
Dim nytbl As Table
Dim CheckBox1 As ContentControl
Set CheckBox1 = Selection.Range.ContentControls.Add(wdContentControlCheckBox)
' CheckBox1.Checked = False
If (CheckBox1.Checked = True) Then
Set MyRange = ActiveDocument.Content
MyRange.Collapse Direction:=wdCollapseEnd
Set nytbl = ActiveDocument.Tables.Add(Range:=MyRange, NumRows:=3, NumColumns:=1)
nytbl.Select
nytbl.AutoFormat Format:=wdTableFormatList3
' formating of the table
With nytbl
.Cell(1, 1).Height = 30
.Cell(1, 1).Shading.BackgroundPatternColor = -738132173
.Cell(1, 1).Range.Font.Name = "Arial"
.Cell(1, 1).Range.Font.Size = 12
.Cell(1, 1).Range.Font.Bold = True
.Cell(1, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Cell(1, 1).Range.Font.TextColor = wdColorBlack
.Cell(1, 1).Range.InsertAfter " APPLIKATIONER "
.Cell(1, 1).VerticalAlignment = wdCellAlignVerticalCenter
.Cell(2, 1).Height = 30
.Cell(2, 1).Shading.BackgroundPatternColor = RGB(226, 239, 217)
.Cell(2, 1).Range.Font.Name = "Arial"
.Cell(2, 1).Range.Font.Size = 10
.Cell(2, 1).Range.Font.Bold = False
.Cell(2, 1).Range.Font.Italic = True
.Cell(2, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
.Cell(2, 1).Range.Font.TextColor = wdColorBlack
.Cell(2, 1).Range.InsertAfter " Applikationer kan indeholde data vedr. installerede applikationer. "
.Cell(2, 1).VerticalAlignment = wdCellAlignVerticalCenter
End With
End If
ActiveDocument.Paragraphs.Add 'insert new empty line
ActiveDocument.Paragraphs.Add 'insert new empty line
ActiveDocument.Paragraphs.Add 'insert new empty line
End Sub
I'm trying to make a macro where users can select a table within a document and switch the orientation of the specific page it's on to landscape. I've tried both recording doing the action and writing the macro myself but it never seems to work properly. This is as close as I've gotten but it makes the page the table is on and everything before it landscape.
Sub TableLandscape()
'
' TableLandscape Macro
'
'
'Selection.Collapse Direction:=wdCollapseEnd
'Selection.InsertBreak Type:=wdSectionBreakContinuous
'ActiveDocument.Range(Start:=Selection.Start, End:=Selection.Start).Collapse Direction:=wdCollapseStart
'Selection.InsertBreak _
Type:=wdSectionBreakNextPage
Selection.Start = Selection.Start + 1
ActiveDocument.Range(Start:=Selection.End, End:=Selection.End).InsertBreak _
Type:=wdSectionBreakNextPage
With Selection.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientLandscape
.TopMargin = InchesToPoints(1)
.BottomMargin = InchesToPoints(1)
.LeftMargin = InchesToPoints(1)
.RightMargin = InchesToPoints(1)
.Gutter = InchesToPoints(0)
.HeaderDistance = InchesToPoints(0.6)
.FooterDistance = InchesToPoints(0.5)
.PageWidth = InchesToPoints(11)
.PageHeight = InchesToPoints(8.5)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionContinuous
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With
'ActiveDocument.Range(Start:=Selection.End, End:=Selection.End).InsertBreak _
'Type:=wdSectionBreakNextPage
End Sub
Here's how to do that:
Sub RotatePage()
Dim TableRange As Range, TableStart As Range, TableEnd As Range
Set TableRange = Selection.Tables(1).Range
Set TableStart = TableRange.Duplicate
With TableStart
.SetRange Start:=TableStart.Start - 1, End:=TableStart.End
.Collapse Direction:=wdCollapseStart
.InsertBreak Type:=wdSectionBreakNextPage
End With
Set TableEnd = TableRange.Duplicate
With TableEnd
.SetRange Start:=TableEnd.Start, End:=TableEnd.End + 1
.Collapse Direction:=wdCollapseEnd
.InsertBreak Type:=wdSectionBreakNextPage
End With
TableRange.PageSetup.Orientation = wdOrientLandscape
End Sub
I wrote the code below to add an image to header. I placed the .png file in a network file. The following code works in my PC, but not in a different PC which also has access to the same network drive. It does import the image into the header but throws an error at the (.addpicture) line as shown in attached image. Wondering why the same code which works in one computer is bombing in the other one. Appreciate any directions. Thanks
Private Sub AddHeaderToRange(rng As Word.Range)
Dim sFindText As String
With rng
.Tables.Add Range:=rng, NumRows:=1, NumColumns:=2 'DefaultTableBehavior:=wdWord8TableBehavior,
AutoFitBehavior:=wdAutoFitFixed
With .Tables(1)
.PreferredWidth = Application.InchesToPoints(7)
.Rows.Alignment = wdAlignRowCenter
.Borders.InsideLineStyle = wdLineStyleNone
.Borders.OutsideLineStyle = wdLineStyleSingle
.Rows.SetLeftIndent LeftIndent:=0, RulerStyle:=wdAdjustNone
.Columns(1).SetWidth ColumnWidth:=200, RulerStyle:=wdAdjustNone
.Columns(2).SetWidth ColumnWidth:=225, RulerStyle:=wdAdjustNone
.cell(1, 1).Range.InlineShapes.AddPicture
Filename:="\\srv2\gv1\eng\strss\Pics\Testlogo.png", LinkToFile:=False,
SaveWithDocument:=True
.cell(1, 2).Range.Font.name = "Arial"
.cell(1, 2).Range.Font.Size = 12
.cell(1, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
.cell(1, 2).Range.Text = Sheets("Start").Range("P9").Value & " " &
Sheets("Start").Range("P10").Value
sFindText = Sheets("Start").Range("P9").Value & " " & Sheets("Start").Range("P10").Value
.cell(1, 2).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
For Each r In .Rows
r.Borders(wdBorderLeft) = wdLineStyleNone
r.Borders(wdBorderRight) = wdLineStyleNone
r.Borders(wdBorderTop) = wdLineStyleNone
Next
.Rows(1).Cells.VerticalAlignment = wdAlignVerticalBottom
.AutoFitBehavior (wdAutoFitWindow)
'.Rows.WrapAroundText = True
End With
.ParagraphFormat.SpaceBefore = 0
.ParagraphFormat.SpaceAfter = 0
End With
With rng.Find
.Text = sFindText
If .Execute(Forward:=True) = True Then
rng.Fields.Add rng, _
wdFieldEmpty, _
"DocProperty TitleReference", PreserveFormatting:=True
End If
End With
Exit Sub
eh:
Call Errorhandler("AddHeaderToRange", Err)
End Sub
The syntax is:
Activedocument.Tables(1).Rows(1).Cells(1).Range.InlineShapes.AddPicture
After you fix that, you'll also get errors for the following lines that use .cell instead of Rows(1).Cells(1).
I am looking the for the correct syntax to use a text function to find strings that contain underscores. I have a very large document that has numerous tables names with underscores. They are in the format abc_def or abc_def_ghi or abc_def_ghi_jkl etc.
I have tried various combinations and cannot get anything to work as I expect it to. Below is my latest iteration.
Sub ExtractTablesToNewDocument()
'=========================
'Macro created 2008 by Lene Fredborg, DocTools - www.thedoctools.com
'THIS MACRO IS COPYRIGHT. YOU ARE WELCOME TO USE THE MACRO BUT YOU MUST KEEP THE LINE ABOVE.
'YOU ARE NOT ALLOWED TO PUBLISH THE MACRO AS YOUR OWN, IN WHOLE OR IN PART.
'=========================
'The macro creates a new document,
'finds all words consisting of 3 or more uppercase letters
'in the active document and inserts the words
'in column 1 of a 3-column table in the new document
'Each acronym is added only once
'Use column 2 for definitions
'Page number of first occurrence is added by the macro in column 3
'Minor adjustments are made to the styles used
'You may need to change the style settings and table layout to fit your needs
'=========================
Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim strListSep As String
Dim strAcronym As String
Dim oTable As Table
Dim oRange As Range
Dim n As Long
Dim strAllFound As String
Dim Title As String
Dim Msg As String
Title = "Extract Acronyms to New Document"
'Show msg - stop if user does not click Yes
Msg = "This macro finds all words consisting of 3 or more " & _
"uppercase letters and extracts the words to a table " & _
"in a new document where you can add definitions." & vbCr & vbCr & _
"Do you want to continue?"
If MsgBox(Msg, vbYesNo + vbQuestion, Title) <> vbYes Then
Exit Sub
End If
Application.ScreenUpdating = False
'Find the list separator from international settings
'May be a comma or semicolon depending on the country
strListSep = Application.International(wdListSeparator)
'Start a string to be used for storing names of acronyms found
strAllFound = "#"
Set oDoc_Source = ActiveDocument
'Create new document for acronyms
Set oDoc_Target = Documents.Add
With oDoc_Target
'Make sure document is empty
.Range = ""
'Insert info in header - change date format as you wish
.PageSetup.TopMargin = CentimetersToPoints(3)
.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
"Acronyms extracted from: " & oDoc_Source.FullName & vbCr & _
"Created by: " & Application.UserName & vbCr & _
"Creation date: " & Format(Date, "MMMM d, yyyy")
'Adjust the Normal style and Header style
With .Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 10
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With .Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Insert a table with room for acronym and definition
Set oTable = .Tables.Add(Range:=.Range, NumRows:=2, NumColumns:=3)
With oTable
'Format the table a bit
'Insert headings
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.Cell(1, 1).Range.Text = "Acronym"
.Cell(1, 2).Range.Text = "Definition"
.Cell(1, 3).Range.Text = "Page"
'Set row as heading row
.Rows(1).HeadingFormat = True
.Rows(1).Range.Font.Bold = True
.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 20
.Columns(2).PreferredWidth = 70
.Columns(3).PreferredWidth = 10
End With
End With
With oDoc_Source
Set oRange = .Range
n = 1 'used to count below
With oRange.Find
'Use wildcard search to find strings consisting of 3 or more uppercase letters
'Set the search conditions
'NOTE: If you want to find acronyms with e.g. 2 or more letters,
'change 3 to 2 in the line below
.Text = "<*>[_]<*>"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWildcards = True
'Perform the search
Do While .Execute
'Continue while found
strAcronym = oRange
'Insert in target doc
'If strAcronym is already in strAllFound, do not add again
If InStr(1, strAllFound, "#" & strAcronym & "#") = 0 Then
'Add new row in table from second acronym
If n > 1 Then oTable.Rows.Add
'Was not found before
strAllFound = strAllFound & strAcronym & "#"
'Insert in column 1 in oTable
'Compensate for heading row
With oTable
.Cell(n + 1, 1).Range.Text = strAcronym
'Insert page number in column 3
.Cell(n + 1, 3).Range.Text = oRange.Information(wdActiveEndPageNumber)
End With
n = n + 1
End If
Loop
End With
End With
'Sort the acronyms alphabetically - skip if only 1 found
If n > 2 Then
With Selection
.Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _
:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
'Go to start of document
.HomeKey (wdStory)
End With
End If
Application.ScreenUpdating = True
'If no acronyms found, show msg and close new document without saving
'Else keep open
If n = 1 Then
Msg = "No acronyms found."
oDoc_Target.Close savechanges:=wdDoNotSaveChanges
Else
Msg = "Finished extracting " & n - 1 & " acronymn(s) to a new document."
End If
MsgBox Msg, vbOKOnly, Title
'Clean up
Set oRange = Nothing
Set oDoc_Source = Nothing
Set oDoc_Target = Nothing
Set oTable = Nothing
End Sub
Try:
.Text = "[! ]#_[! ]{1,}"
This will find strings containing however many underscores there might be, including where those strings start or end with an underscore.
Try:
Sub AcronymLister()
Application.ScreenUpdating = False
Dim StrTmp As String, StrAcronyms As String, i As Long, j As Long, k As Long, Rng As Range, Tbl As Table
StrAcronyms = "Acronym" & vbTab & "Page" & vbCr
With ActiveDocument
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = True
.Wrap = wdFindStop
.Text = "[! ^13^t^11]#_[! ^13^t^11]{1,}"
.Replacement.Text = ""
.Execute
End With
Do While .Find.Found = True
If InStr(1, StrAcronyms, .Text, vbBinaryCompare) = 0 Then
StrAcronyms = StrAcronyms & .Text & vbTab & .Information(wdActiveEndAdjustedPageNumber) & vbCr
End If
If Len(.Text) = 0 Then .End = .Paragraphs(1).Range.Next.Start
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
With .Range
Set Rng = .Characters.Last
With Rng
If .Characters.First.Previous <> vbCr Then .InsertAfter vbCr
.InsertAfter Chr(12)
.Collapse wdCollapseEnd
.Style = "Normal"
.Text = StrAcronyms
Set Tbl = .ConvertToTable(Separator:=vbTab, NumRows:=.Paragraphs.Count, NumColumns:=2)
With Tbl
.Columns.AutoFit
.Rows(1).HeadingFormat = True
.Rows(1).Range.Style = "Strong"
.Rows.Alignment = wdAlignRowCenter
End With
.Collapse wdCollapseStart
End With
End With
End With
Set Rng = Nothing: Set Tbl = Nothing
Application.ScreenUpdating = True
End Sub
Note: The above code puts the acronym table at the end of the current document. I've modified the Find expression to exclude tabs, paragraph breaks & line breaks.
Sub AcronymLister()
Application.ScreenUpdating = False
Dim StrTmp As String, StrAcronyms As String, i As Long, j As Long, k As Long, Rng As Range, Tbl As Table
StrAcronyms = "Acronym" & vbTab & "Page" & vbCr
With ActiveDocument
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = True
.Wrap = wdFindStop
.Text = "[! ^13^t^11]#_[! ^13^t^11]{1,}"
.Replacement.Text = ""
.Execute
End With
Do While .Find.Found = True
If InStr(.Text, "_") = 0 Then
If InStr(1, StrAcronyms, .Text, vbBinaryCompare) = 0 Then
StrAcronyms = StrAcronyms & .Text & vbTab & .Information(wdActiveEndAdjustedPageNumber) & vbCr
Else
.End = .Paragraphs(1).Range.Next.Start
End If
End If
If InStr(.Text, "_") > 0 Then
If InStr(1, StrAcronyms, .Text, vbBinaryCompare) = 0 Then
StrAcronyms = StrAcronyms & .Text & vbTab & .Information(wdActiveEndAdjustedPageNumber) & vbCr
Else
.End = .Paragraphs(1).Range.Next.Start
End If
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
With .Range
Set Rng = .Characters.Last
With Rng
If .Characters.First.Previous <> vbCr Then .InsertAfter vbCr
.InsertAfter Chr(12)
.Collapse wdCollapseEnd
.Style = "Normal"
.Text = StrAcronyms
Set Tbl = .ConvertToTable(Separator:=vbTab, NumRows:=.Paragraphs.Count, NumColumns:=2)
With Tbl
.Columns.AutoFit
.Rows(1).HeadingFormat = True
.Rows(1).Range.Style = "Strong"
.Rows.Alignment = wdAlignRowCenter
End With
.Collapse wdCollapseStart
End With
End With
End With
Set Rng = Nothing: Set Tbl = Nothing
Application.ScreenUpdating = True
End Sub
#macropod i added a loop to handle zero length strings and the code appears to be working. I know this is not the most efficient method, do you have any suggestions for improvement? Thank you again for walking me through this i really appreciate all your help and knowledge.
I have a large file I have split into many separate rtf files with this slightly modified code I got online. The problem was I didn't want to include the Heading 1 text in the output file. However the Heading 1 data is used to create the filename of each output document.
This is the format of the file I am splitting to new files.
1.1.1 This would be marked Heading1 style
some text in here some text in here some text in here some text in here
1.1.2 This would be marked Heading1 style
some text in here some text in here some text in here some text in here
1.1.3 This would be marked Heading1 style
some text in here some text in here some text in here some text in here
=============================================================================== So what it outputs are files named 1.1.1.rtf, 1.1.2.rtf etc and would just contain the body text, but no heading.
repeats to end
Any guidance will be appreciated.
Sub aSplitOnHeadings()
'
' SplitOnHeadings Macro
'
'
Application.ScreenUpdating = False
Dim StrTmplt As String, StrPath As String, StrFlNm As String, Rng As Range, Doc As Document, i As Long, extension As String
extension = ".rtf" ' Jon added so we can have 1.1.1 for the references
With ActiveDocument
StrTmplt = .AttachedTemplate.FullName
StrPath = .Path & "\"
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Style = "Heading 1"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
Do While .Find.Found
Set Rng = .Paragraphs(1).Range.Duplicate
With Rng
StrFlNm = Replace(.Text, vbCr, "")
For i = 1 To 255 'I took out the chr 46 the full stop because it is legal 44 comma
Select Case i
Case 1 To 31, 33, 34, 37, 42, 47, 58 - 63, 91 - 93, 96, 124, 147, 148
StrFlNm = Replace(StrFlNm, Chr(i), "")
End Select
Next
Do
If .Paragraphs.Last.Range.End = ActiveDocument.Range.End Then Exit Do
Select Case .Paragraphs.Last.Next.Style
Case "Heading 1"
Selection.EndKey Unit:=wdLine
Exit Do
Case Else
.MoveEnd wdParagraph, 1
End Select
Loop
End With
Set Doc = Documents.Add(Template:=StrTmplt, Visible:=False)
With Doc
.Range.FormattedText = Rng.FormattedText
.SaveAs2 FileName:=StrPath & StrFlNm & extension, Fileformat:=wdFormatRTF, AddToRecentFiles:=False
.Close False
End With
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End With
Set Doc = Nothing: Set Rng = Nothing
Application.ScreenUpdating = True
'.SaveAs2 FileName:=StrPath & StrFlNm, FileFormat:=wdFormatRTF, AddToRecentFiles:=False
'.SaveAs2 FileName:=StrPath & StrFlNm, Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
End Sub
These two sets macro will work. Each one splits a document on Heading1 style into separate documents with the document named as the Heading1 it was split at, and the Heading1 is not included in the new document. That is just perfect.
Here are the two sets of macro two for output in .rtf and two for docx Also in these macro I removed the . from being an illegal character as I did need the output to be as per the Heading1 exactly. Thanks macropod for taking the time to sort this. I will try to learn more about macros.
Jon.
Sub SplitDocOnHeading1ToRtfWithHeadingInOutput()
'Splits the document on Heading1 style, into new documents, Heading1 is included in the data.
Application.ScreenUpdating = False
Dim Rng As Range, DocSrc As Document, DocTgt As Document
Dim i As Long, StrTxt As String: Const StrNoChr As String = """*/\:?|"
Set DocSrc = ActiveDocument
With DocSrc.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = True
.Forward = True
.Text = ""
.Style = wdStyleHeading1
.Replacement.Text = ""
.Wrap = wdFindStop
.Execute
End With
Do While .Find.Found
Set Rng = .Paragraphs(1).Range
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
Set DocTgt = Documents.Add(DocSrc.AttachedTemplate.FullName)
With DocTgt
Application.ScreenUpdating = False
.Range.FormattedText = Rng.FormattedText
StrTxt = Split(.Paragraphs.First.Range.Text, vbCr)(0)
' Strip out illegal characters
For i = 1 To Len(StrNoChr)
StrTxt = Replace(StrTxt, Mid(StrNoChr, i, 1), "_")
Next
'.Paragraphs.First.Range.Delete 'un comment this line if you don't want to retain headings in the output file
.SaveAs2 FileName:=DocSrc.Path & "\" & StrTxt & ".rtf", Fileformat:=wdFormatRTF, AddToRecentFiles:=False
.Close False
End With
.Start = Rng.End
.Find.Execute
Loop
End With
Set Rng = Nothing: Set DocSrc = Nothing: Set DocTgt = Nothing
Application.ScreenUpdating = True
End Sub
Sub SplitDocOnHeading1ToRtfNoHeadingInOutput()
'Splits the document on Heading1 style, into new documents, Heading1 is NOT included in the data
Application.ScreenUpdating = False
Dim Rng As Range, DocSrc As Document, DocTgt As Document
Dim i As Long, StrTxt As String: Const StrNoChr As String = """*/\:?|"
Set DocSrc = ActiveDocument
With DocSrc.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = True
.Forward = True
.Text = ""
.Style = wdStyleHeading1
.Replacement.Text = ""
.Wrap = wdFindStop
.Execute
End With
Do While .Find.Found
Set Rng = .Paragraphs(1).Range
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
Set DocTgt = Documents.Add(DocSrc.AttachedTemplate.FullName)
With DocTgt
Application.ScreenUpdating = False
.Range.FormattedText = Rng.FormattedText
StrTxt = Split(.Paragraphs.First.Range.Text, vbCr)(0)
' Strip out illegal characters
For i = 1 To Len(StrNoChr)
StrTxt = Replace(StrTxt, Mid(StrNoChr, i, 1), "_")
Next
.Paragraphs.First.Range.Delete 'comment out this line if you want to retain headings in the output file
.SaveAs2 FileName:=DocSrc.Path & "\" & StrTxt & ".rtf", Fileformat:=wdFormatRTF, AddToRecentFiles:=False
.Close False
End With
.Start = Rng.End
.Find.Execute
Loop
End With
Set Rng = Nothing: Set DocSrc = Nothing: Set DocTgt = Nothing
Application.ScreenUpdating = True
End Sub
Sub SplitDocOnHeading1ToDocxWithHeadingInOutput()
'Splits the document on Heading1 style, into new documents, Heading1 is included in the data.
Application.ScreenUpdating = False
Dim Rng As Range, DocSrc As Document, DocTgt As Document
Dim i As Long, StrTxt As String: Const StrNoChr As String = """*/\:?|"
Set DocSrc = ActiveDocument
With DocSrc.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = True
.Forward = True
.Text = ""
.Style = wdStyleHeading1
.Replacement.Text = ""
.Wrap = wdFindStop
.Execute
End With
Do While .Find.Found
Set Rng = .Paragraphs(1).Range
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
Set DocTgt = Documents.Add(DocSrc.AttachedTemplate.FullName)
With DocTgt
Application.ScreenUpdating = False
.Range.FormattedText = Rng.FormattedText
StrTxt = Split(.Paragraphs.First.Range.Text, vbCr)(0)
' Strip out illegal characters
For i = 1 To Len(StrNoChr)
StrTxt = Replace(StrTxt, Mid(StrNoChr, i, 1), "_")
Next
'.Paragraphs.First.Range.Delete 'un comment this line if you don't want to retain headings in the output file
.SaveAs2 FileName:=DocSrc.Path & "\" & StrTxt & ".docx", Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
.Close False
End With
.Start = Rng.End
.Find.Execute
Loop
End With
Set Rng = Nothing: Set DocSrc = Nothing: Set DocTgt = Nothing
Application.ScreenUpdating = True
End Sub
Sub SplitDocOnHeading1ToDocxNoHeadingInOutput()
'Splits the document on Heading1 style, into new documents, Heading1 is NOT included in the data
Application.ScreenUpdating = False
Dim Rng As Range, DocSrc As Document, DocTgt As Document
Dim i As Long, StrTxt As String: Const StrNoChr As String = """*/\:?|"
Set DocSrc = ActiveDocument
With DocSrc.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = True
.Forward = True
.Text = ""
.Style = wdStyleHeading1
.Replacement.Text = ""
.Wrap = wdFindStop
.Execute
End With
Do While .Find.Found
Set Rng = .Paragraphs(1).Range
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
Set DocTgt = Documents.Add(DocSrc.AttachedTemplate.FullName)
With DocTgt
Application.ScreenUpdating = False
.Range.FormattedText = Rng.FormattedText
StrTxt = Split(.Paragraphs.First.Range.Text, vbCr)(0)
' Strip out illegal characters
For i = 1 To Len(StrNoChr)
StrTxt = Replace(StrTxt, Mid(StrNoChr, i, 1), "_")
Next
.Paragraphs.First.Range.Delete 'comment out this line if you want to retain headings in the output file
.SaveAs2 FileName:=DocSrc.Path & "\" & StrTxt & ".docx", Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
.Close False
End With
.Start = Rng.End
.Find.Execute
Loop
End With
Set Rng = Nothing: Set DocSrc = Nothing: Set DocTgt = Nothing
Application.ScreenUpdating = True
End Sub
Try something based on:
Sub SplitDoc()
Application.ScreenUpdating = False
Dim Rng As Range, DocSrc As Document, DocTgt As Document
Dim i As Long, StrTxt As String: Const StrNoChr As String = """*./\:?|"
Set DocSrc = ActiveDocument
With DocSrc.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = True
.Forward = True
.Text = ""
.Style = wdStyleHeading1
.Replacement.Text = ""
.Wrap = wdFindStop
.Execute
End With
Do While .Find.Found
Set Rng = .Paragraphs(1).Range
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
Set DocTgt = Documents.Add(DocSrc.AttachedTemplate.FullName)
With DocTgt
.Range.FormattedText = Rng.FormattedText
StrTxt = Split(.Paragraphs.First.Range.Text, vbCr)(0)
' Strip out illegal characters
For i = 1 To Len(StrNoChr)
StrTxt = Replace(StrTxt, Mid(StrNoChr, i, 1), "_")
Next
.Paragraphs.First.Range.Delete
.SaveAs2 FileName:=DocSrc.Path & "\" & StrTxt & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
.Close False
End With
.Start = Rng.End
.Find.Execute
Loop
End With
Set Rng = Nothing: Set DocSrc = Nothing: Set DocTgt = Nothing
Application.ScreenUpdating = True
End Sub