Question

我有一个大文件，我已经拆分成许多单独的rtf文件，这个稍微修改过的代码我上网了。问题是我不想在输出文件中包含标题1文本。但是，标题1数据用于创建每个输出文档的文件名。

这是我要拆分为新文件的文件格式。

1.1.1这将标记为Heading1样式

这里有一些文字，这里有一些文字，这里有一些文字

1.1.2这将标记为Heading1样式

这里有一些文字，这里有一些文字，这里有一些文字

1.1.3这将标记为Heading1样式

这里有一些文字，这里有一些文字，这里有一些文字

=============================================== ================================所以输出的是名为1.1.1.rtf，1.1.2.rtf的文件等等，只包含正文，但没有标题。

重复结束

任何指导都将不胜感激。

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

Answer 1

根据以下内容尝试：

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)
    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

Answer 2

这两套宏将起作用。每个文档将Heading1样式的文档拆分为单独的文档，文档名称为Heading1，它被拆分，Heading1不包含在新文档中。那是完美的。以下是.rtf中输出的两组宏二和docx中的两组。另外在这些宏中我删除了。从我是一个非法的角色，因为我确实需要输出完全按照Heading1。感谢macropod花时间对此进行排序。我将尝试了解有关宏的更多信息。

乔恩。

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

如何使用heading1样式作为拆分拆分Word文档（docx或rtf）

2 个答案: