I have found a macro that searches for a Heading1 format and splits my Word document based on that tag.
I want to extract the text from the H1 tag and use that to name the document - I can Debug print the text but I cannot get it to convert to a string.
Im sure its really simple but I cannot get it to work.
Here is my Macro as it stands (kudos to the original author) - It currently asks for a new name for the docs and uses that, I want to replace the ans$ with a string in the naming function
``
Sub Hones()
Dim aDoc As Document
Dim bDoc As Document
Dim Rng As Range
Dim myRng As Range
Dim Rng1 As Range
Dim Rng2 As Range
Dim Counter As Long
Dim Ans$
Dim Foundtext As String
Ans$ = InputBox("Enter Filename", "Incremental number added")
If Ans$ <> "" Then
Set aDoc = ActiveDocument
Set Rng1 = aDoc.Range
Set Rng2 = Rng1.Duplicate
Do
With Rng1.Find
.ClearFormatting
.MatchWildcards = False
.Forward = True
.Format = True
.Style = "Heading 1"
.Execute
End With
If Rng1.Find.Found Then
Foundtext = Rng1.Find.Found
Debug.Print Foundtext
Counter = Counter + 1
Rng2.Start = Rng1.End + 1
With Rng2.Find
.ClearFormatting
.MatchWildcards = False
.Forward = True
.Format = True
.Style = "Heading 1"
.Execute
End With
If Rng2.Find.Found Then
Rng2.Select
Rng2.Collapse wdCollapseEnd
Rng2.MoveEnd wdParagraph, -1
Set Rng = aDoc.Range(Rng1.Start, Rng2.End)
Set bDoc = Documents.Add
bDoc.Content.FormattedText = Rng
bDoc.SaveAs Counter & ". " & Ans$ & ".docx", 16
'bDoc.SaveAs Counter & ". " & Foundtext & ".docx", wdFormatDocumentDefault
bDoc.Close
Else
'This collects from the last Heading 1 to the end of the document.
If Rng2.End < aDoc.Range.End Then
Set bDoc = Documents.Add
Rng2.Collapse wdCollapseEnd
Rng2.MoveEnd wdParagraph, -2
Set Rng = aDoc.Range(Rng2.Start, aDoc.Range.End)
bDoc.Content.FormattedText = Rng
'bDoc.SaveAs Counter & ". " & Foundtext & ".docx", wdFormatDocumentDefault
bDoc.SaveAs Counter & ". " & Ans$ & ".docx", wdFormatDocumentDefault
bDoc.Close
End If
End If
End If
Loop Until Not Rng1.Find.Found
'This is closing End If from Ans$
End If
End Sub
I believe the string contained a return at the end of it which the SaveAs function did not like
I replaced this
Foundtext = Rng1.Find.Found
Debug.Print Foundtext
with this
ftext = CStr(Rng1.Text)
namelength = Len(ftext)
Foundtext = Left(ftext, namelength - 2)
to trim the end off
Related
I have a large number of documents which I need to pull out file name references from, spread out across large blocks of text and footnotes.
I currently have a word VBA code that I think should search for a string (for example "This_") and then the following # of characters, and then paste them into a waiting excel sheet. I am struggling to get it to search both the footnotes and the main body of text.
I've been using the code below, but my work at the moment is making it do something weird. It will find the string I am searching for, but then it will copy from the start of the document the number of times the string has been found -- not the string and its subsequent text.
Any help would be appreciated in modifying this, I believe the issue will be coming from the first half of the 'return data to array section.
Option Explicit
Option Base 1
Sub WordDataToExcel()
Dim myObj
Dim myWB
Dim mySh
Dim txt As String, Lgth As Long, Strt As Long
Dim i As Long
Dim oRng As Range
Dim Tgt As String
Dim TgtFile As String
Dim arr()
Dim ArrSize As Long
Dim ArrIncrement As Long
ArrIncrement = 1000
ArrSize = ArrIncrement
ReDim arr(ArrSize)
'Set parameters Change to your path and filename
TgtFile = "File.xlsx"
If IsWindowsOS Then
Tgt = "C:\users\user\" & TgtFile ' Windows OS
Else
Tgt = "MacintoshHD:Users:" & TgtFile 'Mac OS
End If
txt = InputBox("String to find")
Lgth = InputBox("Length of string to return")
Strt = Len(txt)
'Return data to array
ActiveDocument.StoryRanges(wdFootnotesStory).Select
With Selection.Find
.ClearFormatting
.Forward = True
.Text = txt
.MatchCase = True
.Execute
While .Found
i = i + 1
Set oRng = ActiveDocument.Range _
(Start:=Selection.Range.Start + Strt, _
End:=Selection.Range.End + Lgth)
arr(i) = oRng.Text
oRng.Start = oRng.End
.Execute
If i = ArrSize - 20 Then
ArrSize = ArrSize + ArrIncrement
ReDim Preserve arr(ArrSize)
End If
Wend
End With
ReDim Preserve arr(i)
'Set target and write data
Set myObj = CreateObject("Excel.Application")
Set myWB = myObj.workbooks.Open(Tgt)
Set mySh = myWB.sheets(1)
With mySh
.Range(.Cells(1, 1), .Cells(i, 1)) = myObj.transpose(arr)
End With
'Tidy up
myWB.Close True
myObj.Quit
Set mySh = Nothing
Set myWB = Nothing
Set myObj = Nothing
End Sub
Public Function IsWindowsOS() As Boolean
If Application.System.OperatingSystem Like "*Win*" Then
IsWindowsOS = True
Else
IsWindowsOS = False
End If
End Function
Your code is a little confused as there is an unholy mix of Selection and Range. It is good practice to avoid using Selection as it is very rarely necessary to select anything when working in VBA.
VBA also has compiler constants that can be used to detect, among other things, whether code is being run on a Mac. Not sure if the Mac constant still works reliably as I no longer have one to test on.
'Set parameters Change to your path and filename
TgtFile = "File.xlsx"
'This isn't necessary as there is a compiler constant that can be used to identify code is running on Mac
' If IsWindowsOS Then
' Tgt = "C:\users\user\" & TgtFile ' Windows OS
' Else
' Tgt = "MacintoshHD:Users:" & TgtFile 'Mac OS
' End If
#If Mac Then
Tgt = "MacintoshHD:Users:" & TgtFile 'Mac OS
#Else
Tgt = "C:\users\user\" & TgtFile ' Windows OS
#End If
txt = InputBox("String to find")
Lgth = InputBox("Length of string to return")
Strt = Len(txt)
'Return data to array
'not necessary to select the story range
'ActiveDocument.StoryRanges(wdFootnotesStory).Select
Set oRng = ActiveDocument.StoryRanges(wdFootnotesStory)
With oRng
With .Find
.ClearFormatting
.Forward = True
.Text = txt
.MatchCase = True
End With
While .Find.Execute
'a match has been found and oRng redefined to the range of the match
i = i + 1
.MoveEnd wdCharacter, Lgth
arr(i) = .Text
.Collapse wdCollapseEnd
If i = ArrSize - 20 Then
ArrSize = ArrSize + ArrIncrement
ReDim Preserve arr(ArrSize)
End If
Wend
End With
For example, the following code returns both the found text and its page reference:
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, StrFnd As String, StrOut As String
StrFnd = InputBox("String to find")
j = InputBox("String Length to find")
k = j - Len(StrFnd)
For i = 1 To k
StrFnd = StrFnd & "^?"
Next
With ActiveDocument
For i = 1 To 2 ' 1 = wdMainTextStory, 2 = wdFootnotesStory, 3 = wdEndnotesStory, etc.
With .StoryRanges(i)
With .Find
.ClearFormatting
.Text = StrFnd
.Forward = True
.Format = True
.MatchWildcards = False
.Wrap = wdFindStop
.Replacement.Text = ""
End With
Do While .Find.Execute = True
StrOut = StrOut & vbCr & .Text & vbTab
Select Case .StoryType
Case wdMainTextStory
StrOut = StrOut & .Information(wdActiveEndAdjustedPageNumber)
Case wdFootnotesStory
StrOut = StrOut & .Duplicate.Footnotes(1).Reference.Information(wdActiveEndAdjustedPageNumber)
End Select
Loop
End With
Next
End With
MsgBox StrOut
Application.ScreenUpdating = True
End Sub
This is an example of how to search multiple section of your document. Note that I'm using a Collection to gather up the items, so you don't have to keep increasing an array.
Option Explicit
Option Base 1
Sub test()
Dim allFound As Collection
Set allFound = TextFoundReport("This_", 10)
Dim entry As Variant
For Each entry In allFound
Dim partType As Long
Dim text As String
Dim tokens() As String
tokens = Split(entry, "|")
'--- here is where you copy to an Excel sheet
Debug.Print "Part type: " & tokens(0) & " - '" & tokens(1) & "'"
Next entry
End Sub
Private Function TextFoundReport(ByVal text As String, _
ByVal numberOfCharacters As Long) As Collection
Dim whatWeFound As Collection
Set whatWeFound = New Collection
'--- create a list of the document parts to search
Dim docParts As Variant
docParts = Array(wdMainTextStory, wdFootnotesStory, wdEndnotesStory, wdCommentsStory)
Dim foundRng As Range
Dim docPart As Variant
For Each docPart In docParts
ActiveDocument.StoryRanges(docPart).Select
'--- find all occurences in this part and add it to the collection
' the Item in the collection is the story type and the found text
With Selection.Find
.ClearFormatting
.Forward = True
.text = text
.MatchCase = True
.Execute
Do While .found
Set foundRng = ActiveDocument.Range _
(Start:=Selection.Range.Start + Len(text), _
End:=Selection.Range.End + numberOfCharacters)
whatWeFound.Add CLng(docPart) & "|" & foundRng.text
foundRng.Start = foundRng.End
.Execute
Loop
End With
Next docPart
Set TextFoundReport = whatWeFound
End Function
I'm trying to write two VBA codes.
The first one is to add parentheses around the quotes text and remove line breaks and paragraph breaks.
The copied text always has a line break and then paragraph break near the end.
I would like to remove this, add in two double spaced, and put parentheses at the start of the text and right before where the line break was, and add a period at the end and then paste it.
An example would be:
A mandamus is the proper remedy[line break][paragraph break] Marburg v. Madison, 5 U.S. 137, 139 (1803)
Pasted To:
"A mandamus is the proper remedy." Marburg v. Madison, 5 U.S. 137, 139 (1803).
My second code would do the same thing, but flip it and add parentheses as well.
The finished product would like like:
Marburg v. Madison, 5 U.S. 137, 139 (1803) ("A mandamus is the proper remedy.").
How do I manipulate a string on the clipboard like this.
Sub Test()
Application.ScreenUpdating = False
Dim Rng As range
Set Rng = Selection.range
Rng.PasteAndFormat (wdFormatSurroundingFormattingWithEmphasis)
With Rng
.InsertBefore Chr(147)
.MoveStartUntil Chr(11), wdForward
.End = .Start + 2
.Text = Chr(148) & " "
End With
Selection.MoveStartUntil ")", wdForward
Application.ScreenUpdating = True
End Sub
For the Demoflipped, I tried
Rng.PasteAndFormat (wdFormatSurroundingFormattingWithEmphasis)
Try:
Sub DemoStraight()
Application.ScreenUpdating = False
Dim Rng As Range
Set Rng = Selection.Range
With Rng
.Paste
.Text = Chr(34) & Replace(.Text, Chr(11) & vbCr, Chr(34) & ". ")
End With
Application.ScreenUpdating = True
End Sub
and:
Sub DemoFlipped()
Application.ScreenUpdating = False
Dim Rng As Range, StrTmp As String
Set Rng = Selection.Range
With Rng
.Paste
StrTmp = Replace(.Text, Chr(11), "")
.Text = Split(StrTmp, vbCr)(1) & " (" & Chr(34) & Split(StrTmp, vbCr)(0) & Chr(34) & ".)"
End With
Application.ScreenUpdating = True
End Sub
Format retention requires a different approach. For example:
Sub DemoStraight()
Application.ScreenUpdating = False
Dim Rng As Range
Set Rng = Selection.Range
With Rng
.Paste
.InsertBefore Chr(34)
.MoveStartUntil Chr(11), wdForward
.End = .Start + 2
.Text = Chr(34) & ". "
End With
Application.ScreenUpdating = True
End Sub
and:
Sub DemoFlipped()
Application.ScreenUpdating = False
Dim RngA As Range, RngB As Range, StrTmp As String
Set RngA = Selection.Range
With RngA
.Paste
Do While .Characters.Last Like "[ " & Chr(11) & vbCr & "]"
.End = .End - 1
Loop
.InsertBefore " (" & Chr(34)
Set RngB = .Duplicate
With RngB
.MoveStartUntil Chr(11), wdForward
.End = .Start + 2
.Text = Chr(34) & ".) "
.Collapse wdCollapseEnd
.End = RngA.End
End With
.Collapse wdCollapseStart
.FormattedText = RngB.FormattedText
RngB.Text = vbNullString
End With
Application.ScreenUpdating = True
End Sub
I'm attempting to Loop my Dir subroutine rather than copying the code all over again.
The code prompts a user for a search word.
A count is given in the document. Black (1 time), red (2 times), or bolded red (3+ times).
Images in the file are doubled in size. If there are no images a MsgBox says "no images in file".
To modify multiple documents with this program, I need to input a directory (Dir) and then loop through the files of the directory.
Sub austinolson()
Dim WordInput As String
Dim WordCount As Integer
Dim Range As word.Range
WordInput = InputBox("Search for a word")
'Everything below this code
Set Range = ActiveDocument.Content
WordCount = 0
With Range.Find
.ClearFormatting
.Format = False
.Forward = True
.MatchWholeWord = True
.Text = WordInput
.Wrap = wdFindStop
.Execute
Do While .Found
WordCount = WordCount + 1
Range.Collapse word.WdCollapseDirection.wdCollapseEnd
.Execute
Loop
End With
MsgBox ("The word: '" & "" & WordInput & "" & "' shows up " & WordCount & " times in the document")
ActiveDocument.Content.InsertParagraphAfter
Set Range = ActiveDocument.Content
Range.Collapse word.WdCollapseDirection.wdCollapseEnd
Range.Text = "Number occurrences: " & WordCount
If WordCount >= 3 Then
Range.Font.ColorIndex = wdRed
Range.Font.Bold = True
ElseIf WordCount >= 2 Then
Range.Font.ColorIndex = wdRed
Range.Font.Bold = False
Else
Range.Font.ColorIndex = wdBlack
Range.Font.Bold = False
End If
'Inline shape count below'
Dim h As Long
Dim w As Long
Dim rng As Range
Dim Ishape As InlineShape
Set rng = ActiveDocument.Content
If rng.InlineShapes.Count = 0 Then
MsgBox "No images to modify"
End If
For Each Ishape In ActiveDocument.InlineShapes
h = Ishape.Height
w = Ishape.Width
Ishape.Height = 2 * h
Ishape.Height = 2 * w
Next Ishape
'location input:
Dim Path As String
Dim currentFilename As String
currentFilename = ""
Path = ""
Do While (Path = "")
Path = InputBox("Location of documents e.g. C:\203\: ")
If (Path = "") Then
MsgBox ("No location entered, ending program")
Exit Sub
End If
Loop
'Everything above this code:
currentFilename = Dir(Path & "*.docx")
Do While (currentFilename <> "")
MsgBox (currentFilename)
If (currentFilename <> "") Then
Documents.Open (Path & currentFilename)
'
' Need to apply loop inbetween "Above and below code" HERE to the opened word documents.
'
ActiveDocument.Close (wdSaveChanges)
End If
currentFilename = Dir
Loop
End Sub
Here's what I mean - your main Sub gets user input and loops over the files, but the other tasks are split out into discrete Subs/Functions.
Compiled, but not tested, so you may need to fix some things...
Sub MainProgram()
Dim WordInput As String
Dim WordCount As Long, ImageCount As Long
Dim doc As Document
Dim Path As String
Dim currentFilename As String
currentFilename = ""
'get a path from the user
Path = Trim(InputBox("Location of documents e.g. 'C:\203\'"))
If Path = "" Then
MsgBox "No location entered, ending program"
Exit Sub
End If
If Right(Path, 1) <> "\" Then Path = Path & "\" 'ensure trailing slash
'get the search word
WordInput = Trim(InputBox("Search for a word"))
If Len(WordInput) = 0 Then Exit Sub 'maybe add a message here...
'start looping over the folder
currentFilename = Dir(Path & "*.docx")
Do While currentFilename <> ""
Set doc = Documents.Open(Path & currentFilename)
WordCount = CountTheWord(doc, WordInput) 'count the words
TagWordCount doc, WordInput, WordCount 'insert count to doc
ImageCount = ResizeInlineShapes(doc)
Debug.Print "'" & WordInput & "' shows up " & WordCount & " times in '" & doc.Name & "'"
Debug.Print "...and there were " & ImageCount & " images resized"
doc.Close wdSaveChanges
currentFilename = Dir
Loop
End Sub
Function CountTheWord(doc As Document, theWord As String) As Long
Dim WordCount As Long, rng As Range
Set rng = doc.Content
WordCount = 0
With rng.Find
.ClearFormatting
.Format = False
.Forward = True
.MatchWholeWord = True
.Text = theWord
.Wrap = wdFindStop
.Execute
Do While .Found
WordCount = WordCount + 1
rng.Collapse wdCollapseEnd
.Execute
Loop
End With
CountTheWord = WordCount
End Function
'append a word count to the end of the document
Sub TagWordCount(doc As Document, theWord As String, theCount As Long)
Dim rng As Range
doc.Content.InsertParagraphAfter
Set rng = doc.Content
rng.Collapse wdCollapseEnd
rng.Text = "Number occurrences for '" & theWord & "': " & theCount
rng.Font.Bold = (theCount >= 3)
rng.Font.ColorIndex = IIf(theCount >= 2, wdRed, wdBlack)
End Sub
Function ResizeInlineShapes(doc As Document) As Long
Dim rv As Long, Ishape As InlineShape
For Each Ishape In doc.InlineShapes
Ishape.Height = 2 * Ishape.Height
Ishape.Height = 2 * Ishape.Height
rv = rv + 1
Next Ishape
ResizeInlineShapes = rv '<< number of shapes resized
End Function
How to convert string to temporary range so that we can get functionality of range object to work with string.
For example I am doing something like this.
Edit
I have in word table cell 2
With ActiveDocument.Range
For Each Tbl In .Tables
With Tbl
For i = 1 To .Rows.Count
With .Cell(i, 2).Range
If .Hyperlinks.Count > 0 Then
HttpReq.Open "GET", .Hyperlinks(1).Name, False
HttpReq.send
oHtml.body.innerHTML = HttpReq.responseText
StrTxt = oHtml.body.innerText
'missing lne something like set rng.Text = StrTxt
'this part is also not working, but I think I will be able to do it if I get above part working
If rng.Find.Execute(findText:="Abstract:") Then
Set Rng1 = rng( _
Start:=docnew.Paragraphs(1).Range.Start, _
End:=docnew.Paragraphs(2).Range.End)
MsgBox Rng1.Text
With Tbl.Cell(i, 3).Range
.FormattedText = Rng1.FormattedText
End With
End If
End if
Next
End with
Next
End With
This macro is not working so I can't say weather this is right or wrong to do by this mehtod. It's just an Idea.
Is it possible to dim a temp rng?
Is there any better option available to my problem?
I know that this is stub but, this is the code that worked for me.
StrTxt = oHtml.body.innerText
'MsgBox StrTxt
Set docnew = Documents.Add
With docnew
.Range.Text = StrTxt
Set drange = ActiveDocument.Range( _
Start:=ActiveDocument.Paragraphs(1).Range.Start, _
End:=ActiveDocument.Paragraphs(150).Range.End)
drange.Delete
Set Rng1 = ActiveDocument.Range
If Rng1.Find.Execute(findText:="Abstract") Then
Set rng2 = ActiveDocument.Range(Rng1.End, ActiveDocument.Range.End)
If rng2.Find.Execute(findText:=".") Then
strTheText = ActiveDocument.Range(Rng1.End, rng2.Start).Text
strTheText = Replace(strTheText, ": ", ":")
'MsgBox strTheText
End If
End If
.Close (Word.WdSaveOptions.wdDoNotSaveChanges)
End With
Set docnew = Nothing
Application.ScreenUpdating = False
End If
With Tbl.Cell(i, 3).Range
.InsertAfter vbCr & "Abstract" & strTheText & "."
End With
I'd like to split a doc file with some Units in individual units, taking Level 1 Outlined as stop mark. Someone could help me with this? As you can see, I'm a total newbie here. Thanks a lot
Well, I did this. It's not exactly and auto-split process but it does the thing:
Sub CutSelect()
Dim ruta As String
Selection.Cut
ruta = ActiveDocument.Path
Dim doc As Document
x = x + 1
Set doc = Documents.Add
Selection.Paste
'-----You can add some other things to do here
doc.SaveAs ruta & "\" & "Tema " & Format(x, "0")
'-----So here
doc.Close True
End Sub
X is set as global var. You can also do some Sub to restart counting as you wish
Found this. It'll work for text-only documents.
Option Explicit
Sub SplitNotes(delim As String, strFilename As String)
Dim doc As Document
Dim arrNotes
Dim I As Long
Dim x As Long
Dim Response As Integer
Dim ruta As String
ruta = ActiveDocument.Path
'Vector con los delimitadores
arrNotes = Split(ActiveDocument.Range, delim)
Response = MsgBox("This will split the document into " & UBound(arrNotes) + 1 & " sections. Do you wish to proceed?", 4)
If Response = 7 Then Exit Sub
For I = LBound(arrNotes) To UBound(arrNotes)
If Trim(arrNotes(I)) <> "" Then
x = x + 1
Set doc = Documents.Add
doc.Range = arrNotes(I)
doc.SaveAs ruta & "\" & strFilename & Format(x, "0")
doc.Close True
End If
Next I
End Sub
Sub test()
' delimiter & filename
SplitNotes "///", "Tema "
End Sub
But I'd need to do this with full content, tables, images, etc.
I'm working on this too:
Sub TESTSplitNotes(delim As String, strFilename As String)
Dim doc As Document
Dim arrNotes
Dim I As Long
Dim Response As Integer
Dim ruta As String
Dim p As Paragraph
ruta = ActiveDocument.Path
Dim c As Range
Set c = ActiveDocument.Content
With c.Find
.Text = delim & "(*)" & delim
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
.Replacement.Text = ""
End With
'.Select
c.Find.Execute
While c.Find.Found
Debug.Print c.Start
Debug.Print c.End
'COPY CONTENT
Set r = ActiveDocument.Range(Start:=ini, End:=c.End - 3)
r.Select
Debug.Print ActiveDocument.Range.End
Selection.Copy
x = x + 1
Set doc = Documents.Add
Selection.Paste
'PASTE CONTENT
doc.SaveAs ruta & "\" & strFilename & Format(x, "0")
doc.Close True
ini = c.End - 3
Wend
End Sub
This work the first time, But I don't know how the Search iterates between found elements. After it works the first time,, c.end doesn't increase, it still be at the first position (for example, 3106). Does someone know why??