Advertisement
Guest User

Untitled

a guest
Jun 16th, 2019
62
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 1.53 KB | None | 0 0
  1. Sub ExtractHighlightedTextsInSameColor()
  2. Dim objDoc As Document, objDocAdd As Document
  3. Dim objRange As Range
  4. Dim strFindColor As String
  5. Dim highliteColor As Variant
  6. highliteColor = Array(wdYellow, wdTeal)
  7.  
  8. Set objDoc = ActiveDocument
  9. Set objDocAdd = Documents.Add
  10.  
  11. objDoc.Activate
  12.  
  13. For i = LBound(highliteColor) To UBound(highliteColor)
  14. With Selection
  15. .HomeKey Unit:=wdStory
  16. With Selection.Find
  17. .Highlight = True
  18. Do While .Execute
  19. If Selection.Range.HighlightColorIndex = highliteColor(i) Then
  20. Set objRange = Selection.Range
  21. objDocAdd.Range.InsertAfter objRange & vbCr
  22. Selection.Collapse wdCollapseEnd
  23. End If
  24. Loop
  25. End With
  26. End With
  27. Next
  28. End Sub
  29.  
  30. Sub HighlightedColor()
  31. Dim objDoc As Document, objDocAdd As Document
  32. Dim objRange As Range
  33. Dim highliteColor As Variant
  34. highliteColor = Array(wdYellow, wdTeal, wdPink)
  35.  
  36. Set objDoc = ActiveDocument
  37. Set objDocAdd = Documents.Add
  38.  
  39. objDoc.Activate
  40.  
  41. For i = LBound(highliteColor) To UBound(highliteColor)
  42. With Selection
  43. .HomeKey Unit:=wdStory
  44. With Selection.Find
  45. .Highlight = True
  46. Do While .Execute
  47. If Selection.Range.HighlightColorIndex = highliteColor(i) Then
  48. Set objRange = Selection.Range.FormattedText
  49. objRange.Collapse wdCollapseEnd
  50. objDocAdd.Content.FormattedText = objRange
  51. End If
  52. Loop
  53. End With
  54. End With
  55. Next
  56.  
  57. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement