When I insert the data into Bookmark, it goes to the beginning of the line.
What a property needs to be set to insert the text in the middle of the paragraph?
Data is copied from Excel
Tried so far:
Copy range and paste
Copy text from value and pastespecial
Paste is floating everywhere, but not at Bookmark.
If wDoc.Bookmarks.Count = 0 Then GoTo BookmarkMissing
For i = 1 To wDoc.Bookmarks.Count
If wDoc.Bookmarks(i).Name = sBookmarkName Then
Set wdRange = wDoc.Bookmarks(i).Range
Let bBookmarkFound = True
End If
Next i
If Not bBookmarkFound Then GoTo BookmarkMissing
Else
Set wdRange = wDoc.Range
End If
MyData.SetText rngToSend.Value2
MyData.PutInClipboard
On Error Resume Next
On Error GoTo 0
'rngToSend.Copy
'wdRange.PasteSpecial Placement:=wdFloatOverText, DataType:=2
wdRange.InsertAfter
wdRange.Tables(1).ConvertToText Separator:=" "
'wdRange.PasteSpecial Placement:=wdFloatOverText, DataType:=2
'wdRange.PasteSpecial Placement:=wdInLine
Your code can be greatly simplified. There is no need to loop through bookmarks to find if the one you need exists as the object model has a method to do that.
So this code:
If wdoc.Bookmarks.Count = 0 Then GoTo BookmarkMissing
For I = 1 To wdoc.Bookmarks.Count
If wdoc.Bookmarks(I).name = sBookmarkName Then
Set wdRange = wdoc.Bookmarks(I).Range
Let bBookmarkFound = True
End If
Next I
If Not bBookmarkFound Then GoTo BookmarkMissing
Can be replaced with this
If wdoc.Bookmarks.Exists(sBookmarkName) Then
wdoc.Bookmarks(sBookmarkName).Range.text = rngToSend.Value2
Else
GoTo BookmarkMissing
End If
Since you're moving plain text, the clipboard is not necessary.
wDoc.Bookmarks(i).Range.Text = rngToSend.Value2
Thank you guys for your help. However, I had a bug, one old line of code (not visible in my post_ was still pasting value as a Excel range and inserting a table instead of text.
So now is solved
Related
Since nobody was able to help me with the problem I posted here before (link is below), I am now trying to solve the task through VBA.
Finding a heading in word file and copying entire paragraph thereafter to new word file with python
To briefly recap, I have a large amount of word files, which I would like to reduce to a more readable size each. In each file, there is one heading that appears several times, always formated as a 'Heading 2'. I look for this specific heading which occurs several times in a document and I want to copy all the text parts in just these chapters with the respective heading to a new word document.
I decided to create an excel file in which I list the files and the respective heading of the chapters that I want to copy (see picture below).
To do this now I have written the following code:
Sub SelectData()
Application.ScreenUpdating = False
Dim WdApp As Word.Application
Set WdApp = CreateObject("Word.Application")
Dim Doc As Word.Document
Dim NewDoc As Word.Document
Dim HeadingToFind As String
Dim ChapterToFind As String
Dim StartRange As Long
Dim EndRange As Long
Dim WkSht As Worksheet
Dim LRow As Long
Dim i As Long
Set WkSht = ThisWorkbook.Sheets("Sheet1")
LRow = WkSht.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row
With WkSht
For i = 1 To LRow
If Dir(.Cells(i, 1).Text, vbNormal) = "" Then
.Cells(i, 3).Value = "Please check File Location"
Else
Set Doc = WdApp.Documents.Open(Filename:=.Cells(i, 1).Text, _
AddToRecentFiles:=False, Visible:=False, ReadOnly:=False)
Set NewDoc = Documents.Add
ChapterToFind = LCase(.Cells(i, 2).Text)
With Doc
Selection.HomeKey Unit:=wdStory
With Selection
With .Find
.ClearFormatting
.Text = ChapterToFind
.MatchWildcards = False
.MatchCase = True
.Execute
End With
If .Find.Found Then
.Collapse wdCollapseStart
With .Find
.Text = ""
.Style = "Heading 2"
.Forward = False
.Execute
End With
.MoveDown Count:=1
.HomeKey Unit:=wdLine
StartRange = .Start
.Find.Forward = True
.Find.Execute
.Collapse wdCollapseStart
.MoveUp Count:=1
.EndKey Unit:=wdLine
EndRange = .End
Doc.Range(StartRange, EndRange).Copy
NewDoc.Content.Paste
NewDoc.SaveAs2 Doc.Path & "Clean" & ".docx", wdFormatFlatXML
Else
WkSht.Cells(i, 4).Value = "Error Chapter Not Found"
End If
End With
End With
WdApp.Quit
Set Doc = Nothing: Set NewDoc = Nothing: Set WdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End If
Next
End With
End Sub
However I am really struggling. It seems to not work as I constantly get an error with the command (RunTimeError 438):
Selection.HomeKey Unit:=wdStory
I am aware that I have to activate the Microsoft Word 15.0 Object Library in the references to be able to get word commands. Nevertheless it is not working.
I would greatly appreciate any help, I am also open to other suggestions of course.
The word files look something like in the picture below, however the chapter that I want to extract can occur several times within one word document. As a result my code would probably need a loop or something, I was not able to get this done.
Also I have considered the following links to the topic:
Use VBA with Powerpoint to Search titles in a Word Doc and Copy Text into another Word Document
VBA: open word from excel
word vba: select text between headings
Did I understand this correctly? The following code is the core of what I think you're trying to do. It finds the first Heading 2, then finds all the paragraphs after it until it finds another header of any type or the end of the document. startCopyRange and endCopyRange is the range of those paragraphs. You'll have to piece this into your Excel routine.
A few notes. Always save the active document to a variable and work from that; the user is then free to change active documents while this routine is running. Never use Selection, always use ranges. Never use relative movements like Move, always use API calls.
Sub SelectData()
Dim Doc As Word.Document
Set Doc = ActiveDocument
Dim findRange As Range
Set findRange = Doc.Range
ChapterToFind = "My Chapter"
findRange.Find.Text = ChapterToFind
findRange.Find.Style = "Heading 2"
findRange.Find.MatchCase = True
Dim startCopyRange As Long
Dim endCopyRange As Long
Do While findRange.Find.Execute() = True
startCopyRange = findRange.End + 1
endCopyRange = -1
'findRange.Select
Dim myParagraph As Paragraph
Set myParagraph = findRange.Paragraphs(1).Next
Do While Not myParagraph Is Nothing
myParagraph.Range.Select 'Debug only
If InStr(myParagraph.Style, "Heading") > 0 Then
endCopyRange = myParagraph.Range.Start - 0
End If
If myParagraph.Next Is Nothing Then
endCopyRange = myParagraph.Range.End - 0
End If
If endCopyRange <> -1 Then
Doc.Range(startCopyRange, endCopyRange).Select 'Debug only
DoEvents
Exit Do
End If
Set myParagraph = myParagraph.Next
DoEvents
Loop
Loop
End Sub
I have an Access 2010 application where I run a SQL query and output the results to Excel. I'm using the Excel subtotal command to create subtotals. That works fine, but on the total rows only the text ("XXX Count") is bold and the values are not bold. Our client would like the entire row bold. I've tried a couple ways without success. How do I do the entire row in the subtotals?
So here is what I currently have:
This is correct except I need all of row 5, 8, 16, and 17 bold like this:
Here is my code to create the Excel file from Access (this all works except for the bold issues):
Public Sub ExportToExcel(query)
Dim appXL As Object
Dim wbk As Object
Dim wksNew As Object
Set appXL = CreateObject("Excel.Application")
Set wbk = appXL.Workbooks.Add
Set wksNew = wbk.Worksheets("Sheet1")
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Set appXL = CreateObject("Excel.Application")
appXL.Visible = True
Set wbk = appXL.Workbooks.Add
Set wksNew = wbk.Worksheets(1)
Set cn = CurrentProject.AccessConnection
Set rs = New ADODB.Recordset
With rs
Set .ActiveConnection = cn
.Source = query
.Open
End With
With rs
'Put recordset into new wks
wksNew.Cells(2, 1).CopyFromRecordset rs
'And add headers
Dim i As Long
For i = 0 To .Fields.Count - 1
wksNew.Cells(1, i + 1).Value = .Fields(i).Name
wksNew.Cells(1, i + 1).Font.Bold = True
wksNew.Cells(1, i + 1).HorizontalAlignment = xlCenter
Next i
'Now, while the recordset is available...
'The recordset has .fields.count fields
'Subtotals are wanted from field 7 to the end
If .Fields.Count > 13 Then
ReDim ary(14 To .Fields.Count - 1)
For i = LBound(ary) To UBound(ary)
ary(i) = i
Next i
wksNew.Cells(1, 1).CurrentRegion.SubTotal GroupBy:=1, _
TotalList:=ary, Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End If
.Close
End With
End Sub
I tried this code based on this website:
Dim rCell As Range
wksNew.Columns("A:A").Select
Dim rCell As Range
For Each rCell In Selection
If Right(rCell.Value, 5) = "Count" Then
Rows(rCell.Row).Interior.ColorIndex = 36
End If
Next
but it returned a "Method or data member not found" error on the item rCell.Value.
I also tried it like this:
Dim rCell As Range
wksNew.Columns("A:A").Select
For Each rCell In Selection
If Right(rCell, 5) = "Count" Then
Selection.Font.Bold = True
End If
Next
But I got the error "ActiveX component can't create object" on the For Each line.
How do I bold the entire row for the subtotals?
You're getting an error because Access doesn't know what Selection is unless you tell it that it's connected to your Excel instance.
For Each rCell In Selection
However, don't need to select anything, or check the whole column:
Dim rCell As Range
For Each rCell In wksNew.UsedRange.Columns(1).Cells
If Right(rCell, 5) = "Count" Then
rCell.Font.Bold = True
End If
Next
Have you tried a Pivot Table?? It is easier to manage format or layout and you don't have to change too much your code because you just put your RecordSet in a PivotTableCache like the second example in this.
Rather than looping, I'd suggest collapsing the outline and formatting the visible cells:
with wksNew.Cells(1, 1).CurrentRegion
.Outlinelevel = 2
.specialcells(12).Font.Bold = True
.Outlinelevel = 3
End With
Thanks for all the suggestions. No one posted a solution that worked entirely, so here's what I ended up using:
Dim c As Object
For Each c In wksNew.Range("A1:A500")
If c.Value Like "*Total" Then
c.Offset(0, 13).Font.Bold = True
c.Offset(0, 14).Font.Bold = True
c.Offset(0, 15).Font.Bold = True
End If
Next
The only thing that concerns me is that I'm assuming this only has 500 rows. I couldn't find a way to find the number of rows and have it search only those. If I included the whole column, it took a couple minutes to complete the loop which I didn't think the client would like. Any suggestions on how to find the last row?
I would
Display level 2 of the outline, all the subtotals
Select the whole area
Use GoTo Special to select only visible cells
Apply the formatting
Change the header row formatting if it should be different
Display all the levels again (level 3)
This code demonstrates:
Sub Macro4()
Application.ScreenUpdating = False
ActiveSheet.Outline.ShowLevels RowLevels:=2
Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Font.Bold = True
'change the header row if necessary
Range(Range("A1"), Range("A1").End(xlToRight)).Font.Italic = True
ActiveSheet.Outline.ShowLevels RowLevels:=3
End Sub
I created a macro in Excel 2010, that works quite fine when called from the Macros dialog or the VB window. All's fine at that point. Now, I tried my hand at customized ribbons, and used Custom UI Editor to create a new tab, with custom icons to call my macro. And it's not fine.
The call to the macro works, the macro seems to run properly, scanning each sheet as it should, looking for comments and acting on them, but when it's completed, almost none of the comments were modified as they should have been.
And that's my issue: when I run the macro "normally", it works as planned, it's only when I try to call it from its custom icon that it doesn't do what it's supposed to do (while still seeming to when clicked).
Anyone has an idea what could be wrong?
I don't think it's the code, as I said, it works fine when called from Macros or the VB window
Edit: As I said, I don't think the code is the problem, as it executes without error (it just doesn't do what it's supposed to), but as requested, I post it here:
Sub ImportCommentsFromWord(control As IRibbonControl)
Dim xComment As Comment
Dim xSheet As Worksheet
Dim wApp As Object
'Opens Word if not already open
On Error Resume Next
Set wApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Err.Clear
Set wApp = CreateObject("Word.Application")
End If
wApp.Visible = False
For Each xSheet In ActiveWorkbook.Worksheets
'Activates each sheet one after another
xSheet.Activate
sName = xSheet.Name
expName = Application.ActiveWorkbook.Path + "\" + sName + ".docx"
'Checks if there are comments in active sheet
For Each xComment In xSheet.Comments
CommsInSheet = 1
Next
If CommsInSheet = 1 Then
'Opens the translated document to import comments into the sheet
wApp.Documents.Open (expName)
wApp.Selection.ClearFormatting
wApp.Selection.Find.MatchWildcards = False
wApp.Selection.WholeStory
wApp.Selection.MoveLeft
FileEnd = 0
'Imports comments until end of file is reached
While FileEnd = 0
wApp.Selection.ExtendMode = True
wApp.Selection.MoveRight
With wApp.Selection.Find
.Text = "^l"
End With
wApp.Selection.Find.Execute
DestCell = Mid(wApp.Selection.Text, 2, Len(wApp.Selection.Text) - 2)
wApp.Selection.ExtendMode = False
wApp.Selection.MoveRight
wApp.Selection.ExtendMode = True
With wApp.Selection.Find
.Text = "^l"
End With
wApp.Selection.Find.Execute
wApp.Selection.ExtendMode = False
DestComm = Left(wApp.Selection.Text, Len(wApp.Selection.Text) - 1)
wApp.Selection.MoveRight
wApp.Selection.MoveLeft
wApp.Documents.Add DocumentType:=0
wApp.Selection.Text = DestComm
With wApp.Selection.Find
.Text = "^p"
.Replacement.Text = Chr(10)
End With
wApp.Selection.Find.Execute Replace:=wdReplaceAll
wApp.Selection.WholeStory
DestComm = Left(wApp.Selection.Text, Len(wApp.Selection.Text) - 1)
wApp.ActiveDocument.Close savechanges:=False
If Right(DestComm, 11) = "END_OF_FILE" Then
DestComm = Left(DestComm, Len(DestComm) - 11)
FileEnd = 1
End If
xSheet.Range(DestCell).Comment.Text Text:=DestComm
Wend
'Closes the Word document
wApp.ActiveDocument.Close savechanges:=False
End If
CommsInSheet = 0
Next
wApp.Visible = True
Set wApp = Nothing
End Sub
Never mind, I found the solution myself: the issue was in the xml code of the customized ribbon, it was calling the wrong macro, so of course it didn't work as expected...
I am getting the Message
Open Read only
Local Copy
Recieve Notification when available
I need to open the doc in the read write mode, and the document is closed before the macro is executed
Also I ahve doubts on the way I am writing the Text
Sub Read_Write_Document()
Dim p As Long, r As Long
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open("C:\Documents and Settings\Desktop\Word_File_read_write_1.docx")
Dim i As Integer
i = 1
With wrdDoc_Read
For p = 1 To .Paragraphs.Count
Set tRange = .Range(Start:=.Paragraphs(p).Range.Start, End:=.Paragraphs(p).Range.End)
tString = tRange.Text
tString = Left(tString, Len(tString) - 1)
If InStr(1, tString, "1") > 0 Then
If Mid(tString, 1, 4) = "date" Then
tRange.Text = "DATE" ' Write Text
End If
End If
Next p
End With
.SaveAs ("C:\Documents and Settings\Desktop\Word_File_read_write_2.docx")
wrdApp.Quit ' close the Word application
Set wrdDoc = Nothing
Set wrdApp = Nothing
End Sub
Couple of things
A
It's always advisable to use Option Explicit
You have declared the word document as wrdDoc but are using wrdDoc_Read
Change the line
With wrdDoc_Read
to
With wrdDoc
B
Next your .SaveAs routine is outside the With - End With and hence will give you error
C
You are directly quitting the word application without closing the word document. It's always good to issue a wrdDoc.Close (False) after a .SaveAs because there are instances where an installed add-in can make changes to your document and quitting the word application will prompt the .SaveAs again.
D
Instead of looping through the cells and replacing the text, you can use .Find and Replace
I am trying to create a macro that can find a particular string in a header, then format the cells in that column. For an example, I have a header called "Purchase Date", "Cap Date", and "Exp Date". I want to be able to find the first instance of "Date" used, format them as text, then find the next occurance and format, etc.
I have created one that will find only the first instance, then not look for any further. Any idea? I have looked up "Find" and "After", but cannot get them to function correctly.
Thanks for any help.
I also struggled moving past the first find. ook at the last part fo the code below from Do While. Maybe you can work something from it.
Sub HyperLinking()
Call HyperLink("Text TO Hyperlink", "C:\Document.docx")
End Sub
Private Function HyperLink(LinkName As String, LinkAddress As String)
Dim WDApp As Object, wd As Object, rn As Long
On Error Resume Next
Set WDApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set WDApp = CreateObject("Word.Application")
End If
On Error Goto 0
Set wd = WDApp.Documents.Open(LinkAddress)
WDApp.Visible = True
Set objWdRange = wd.Content
objWdRange.Find.ClearFormatting
With objWdRange.Find
.Text = LinkName
.Forward = True
.Wrap = wdFindContinue
End With
Do While objWdRange.Find.Execute = True
objWdRange.Hyperlinks.Add Anchor:=objWdRange, Address:=LinkAddress, SubAddress:="", ScreenTip:="Linked Document", TextToDisplay:=LinkName
objWdRange.Find.Execute
Loop
wd.Save
wd.Close
Set wd = Nothing
Set WDApp = Nothing
End Function
One problem is that sometimes, I guess due to formatting, all the words are not found. Maybe someone can help with why this happens?
You can adapt this code to your requirements.
It's not particularly elegant, but this will most likely do the trick for you. Just edit some of the hardcoded values like sheetname and make sure that you don't have more than 99 columns or 999 rows.
Public Sub FormatRowsInDateColumns()
Dim header As String
Worksheets("Sheet1").Activate
'loop through columns
For col = 1 To 99
'check if header cell contains word date
header = Cells(1, col).Value
If InStr(1, header, "date", vbTextCompare) <> 0 Then
'convert cell values to string
For Row = 1 To 999
'Formats value and perserves as text with an apostrophe
Cells(Row, col).Value = "'" & Format(Cells(Row, col).Value, "yyyy/mm/dd")
Next Row
'set column format as text
Columns(col).NumberFormat = "#"
End If
Next col
End Sub