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...
Related
I am trying to make a macro to open a word document and make track changes in accordance with column A and B.
I got this to work, but only if the document that is opened in the track changes mode "Simple Markup".
If it is in any other mode, and I have the following search sentences.
A1: al anden personer B1: alle andre mennesker
A2: anden personer B2: andre mennesker
And the text in the word document is "al anden personer".
The text will be "alle andre menneskerandre mennesker" in other world it will search in the track changes.
Therefore, I am trying to make the Word document always open in simple markup. I have tried using iteration of
ActiveWindow.View.RevisionsFilter.Markup = wdRevisionsMarkupSimple
but could not get it to work.
Hope you can help.
PS: I am fairly new to VBA so if you have any other improvement or hint the I'm all ears.
My code right now is:
Option Explicit
Const wdReplaceAll = 2
Sub FindReplace()
Dim wordApp As Object
Dim wordDoc As Object
Dim myStoryRange As Object
Dim cell As Range
Dim Find1 As String
Dim Replace1 As String
Const wdRevisionsMarkupSimple As Integer = 1
'Dim oRevision As Revision
If Not FileIsOpen("H:\Til excel replace test ark" & ".docx") Then
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = True
Set wordDoc = wordApp.Documents.Open("H:\Til excel replace test ark.docx")
wordDoc.trackrevisions = True
'ActiveWindow.View.RevisionsFilter.Markup = wdRevisionsMarkupSimple cannot get it to work
Else
On Error GoTo ExitSub
End If
With Worksheets("sheet1")
For Each cell In Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
Find1 = cell.Value
Replace1 = cell.Offset(0, 1).Value
For Each myStoryRange In wordDoc.StoryRanges
With myStoryRange.Find
.MatchCase = True
.matchwholeword = True
.Text = Find1
.Forward = True
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.Replacement.Text = Replace1
.Execute Replace:=wdReplaceAll
End With
Next myStoryRange
Next cell
End With
Exit Sub
ExitSub:
MsgBox "Luk word document før du benytter denne macro"
End Sub
Public Function FileIsOpen(FullFilePath As String) As Boolean
Dim ff As Long
On Error Resume Next
ff = FreeFile()
Open FullFilePath For Input Lock Read As #ff
Close ff
FileIsOpen = (Err.Number <> 0)
On Error GoTo 0
End Function
Your issue is a result of your use of late binding.
When using late binding you cannot use the enums or constants from the Word object library, e.g. wdRevisionsMarkupSimple, as Excel doesn't know what those represent. You either have to declare those constants yourself or use their underlying values.
So to activate revisions with simple markup your code needs to be:
ActiveWindow.View.RevisionsFilter.Markup = 1 'wdRevisionsMarkupSimple
EDIT: I also missed something else obvious - Excel also has ActiveWindow in its object model. When writing code across applications you need to be absolutely scrupulous in specifying which application/object the line of code refers to. In this case it should be:
WordApp.ActiveWindow.View.RevisionsFilter.Markup = 1 'wdRevisionsMarkupSimple
You can avoid these errors by adding Option Explicit at the top of the code module. This will prevent your code from compiling when you have undeclared variables. To add this automatically open the VBE and go to Tools | Options. In the Options dialog ensure that Require Variable Declaration is checked.
I'm trying to write data into an Excel workbook that is hosted in our SharePoint document library.
I instantiate Excel from Microsoft Project.
I tried the following:
Check if file can be checked out
If it can be checked out, then open it
Here's the code snippet:
If ExcelApp.Workbooks.CanCheckOut (FileURL) = True Then
Set NewBook = ExcelApp.Workbooks.Open(FileName:=FileURL, ReadOnly:=False)
ExcelApp.Workbooks.CheckOut (FileURL)
Else
MsgBox "File is checked out in another session."
End If
The CanCheckOut function always returns FALSE. I'm not able to tell when a file can be checked out by the Excel instance.
Is it not working because I'm calling the VBA code from MS Project?
My app should be able to check if a file is not checked out, then check it out, update it, and save + check it back in.
I've found through trial and error that Workbooks.CanCheckOut (Filename:= FullName) where FullName is the URL for the SharePoint file only works for files that are not open in the current instance of Excel.
The method will always return False if you have the file open in the current instance of Excel which is obviously the case here.
Workbooks.CheckOut (ActiveWorkbook.FullName) opens the file, checks it out and then inexplicably, closes the file. So opening and checking out a SharePoint file becomes a 3 step process.
Sub CheckOutAndOpen()
Dim TestFile As String
TestFile = "http://spserver/document/Test.xlsb"
If Workbooks.CanCheckOut(TestFile) = True Then
Workbooks.CheckOut(TestFile)
Workbooks.Open (TestFile)
Else
MsgBox TestFile & " can't be checked out at this time.", vbInformation
End If
End Sub
This is all a bit counter intuitive because when working manually with SharePoint files you have to open them to see if they can be checked out and then perform the check-out operation.
Neither MSDN or Excel VBA help mention that the Workbooks.CanCheckOut (Filename:= FullName) method always returns False if you have the file open in the current instance of Excel.
The other methods never worked for me. This will CheckOut the file and either open it hidden and terminate (Visible = False), or you can just have it open (Visible = True) and remove the Quit, BUT while the doc is Checked out, I can't seem to target or check in that mXLApp doc further. The solution is to not leave the mXLApp doc open, but then once closed to open that same doc as normal, and then it will Check in with the Check in code line.
Sub TestCheckOut()
Dim FileName as String
FileName = "http://spserver/document/Test.xlsx"
SP_CheckOut FileName
End Sub
Sub SP_CheckOut(docCheckOut As String)
Set mXlApp = CreateObject("Excel.Application")
' Determine if workbook can be checked out.
' CanCheckOut does not actually mean the doc is not currently checked out, but that the doc can be checked in/out.
If mXlApp.Workbooks.CanCheckOut(docCheckOut) = True Then
mXlApp.Workbooks.Open fileName:=docCheckOut
mXlApp.Workbooks.CheckOut docCheckOut
' False is hidden
mXlApp.Visible = False
mXlApp.Quit
Set mXlApp = Nothing
Workbooks.Open fileName:=docCheckOut
Else
MsgBox "Unable to check out this document at this time."
End If
End Sub
As for Checkin, can't get any methods to work except:
Workbooks(CheckName).checkin SaveChanges:=True, Comments:=""
Sub CheckIn(CheckName As String, CheckPath As String)
' Must be open to save and then checkin
Dim wb As Workbook
On Error Resume Next
Set wb = Workbooks(CheckName)
If Err = 0 Then
WorkbookIsOpen = True
Else
WorkbookIsOpen = False
Set wb = Workbooks.Open(CheckPath)
End If
wb.CheckIn SaveChanges:=True, Comments:=""
End Sub
I did try using a Query on the SharePoint browser link to determine who has the doc checked out (if anyone). This worked sometimes. If it did work, half the time it would take too long to be useful, and the other half of the time it would throw a timeout error. Not to mention the query would disrupt other processes, like saving or certain other macros. So I put together a WebScrape which quickly returns who might have the doc checked out.
Sub TestWho()
Dim SPFilePath As String
SPFilePath = "http://teams.MyCompany.com/sites/PATH/PATH/Fulfillment/Forms/AllItems.aspx"
Debug.Print CheckedByWho(SPFilePath , "YOURdocName.xlsx")
End Sub
Function CheckedByWho(ShareFilePath As String, ShareFileName As String)
Dim ie As Object
Dim CheckedWho As String
Dim ImgTag As String
Dim CheckStart, CheckEnd As Integer
Dim SplitArray() As String
Set ie = GetObject("new:{D5E8041D-920F-45e9-B8FB-B1DEB82C6E5E}")
With ie
.Visible = False
.Navigate ShareFilePath
Do Until .readyState = 4: DoEvents: Loop
Do While .Busy: DoEvents: Loop
End With
CheckedWho = "Not Check Out"
For Each objLink In ie.document.getElementsByTagName("img")
ImgTag = objLink.outerHTML
CheckedOutPos = InStr(objLink.outerHTML, ShareFileName & "
Checked Out To:")
If CheckedOutPos > 0 Then
CheckStart = InStr(objLink.outerHTML, "Checked Out To: ")
CheckedWho = Mid(objLink.outerHTML, CheckedOutPos + 41)
SplitArray = Split(CheckedWho, """")
CheckedWho = SplitArray(0)
End If
Next objLink
CheckedByWho = CheckedWho
ie.Quit
End Function
I am getting inconsistent results when I try to refer to an active workbook. About half the time I get the "Method of 'Sheets' of Object '_Global' not failed" error and other times the code works fine. I don't see a pattern.
The VBA code is part of a Word document that allows the user to open a template Excel file and select/copy text from the Word doc into rows on the Excel file.
In a previous sub I successfully open an Excel template file (I call it a RTM template). In the code below I want to activate the "RTM" worksheet, select the first cell where the template could already have data in it from a previous execution and if there is, then count how many rows of data exist. In this way the new data will be posted in the first row which does not have any data. I am using named ranges in my Workbook to refer to the starting cell ("First_Cell_For_Data").
When I run my code sometimes it runs without error and other times it stops on the "Sheets("RTM").Activate" and gives me the "Method...." error. The same result occurs when I change the variable definition of wb_open to Object. I have also tried using "wb_open.Sheets("RTM").Activate" with the same results.
As suggested in the comments below I added "If wb_open is nothing ...." to debug the issue. I also added the sub List_Open_Workbooks which enumerates the open workbooks (of which there is only 1) and activates the one that matches the name of the one with the correct filename. This is successful. But upon returning to Check_Excel_RTM_Template I still get the Method error on the "Sheets("RTM").Activate" line.
Second Update: after more time diagnosing the problem (which still occurs intermittently) I have added some code that may help getting to the root of the problem. In the "List_Open_Workbooks" sub I test for xlApp.Workbooks.Count = 0. So all references to an open Excel workbook will fail. At this point my template workbook is open in Windows. Am I drawing the correct conclusion?
Third Update: I tried Set wb_open = GetObject(str_filename) where str_filename contains the name of the Excel template file I just opened.
I get the following error message.
Also, I noticed that if I start with a fresh launch of Word and Excel it seems to run just fine.
Sub Check_Excel_RTM_Template(b_Excel_File_Has_Data As Boolean, i_rows_of_data As Integer)
Dim i_starting_row_for_data As Integer
Dim wb_open As Object
Set wb_open = ActiveWorkbook
i_rows_of_data = 0
If wb_open Is Nothing Then
MsgBox "RTM Workbook not open in Check_Excel_RTM_Template"
Call List_Open_Workbooks(b_Excel_File_Has_Data, i_rows_of_data)
Else
' On Error GoTo Err1:
' Sheets("RTM").Activate
' range("First_Cell_For_Data").Select
Workbooks(wb_open.Name).Worksheets("RTM").range("First_Cell_For_Data").Select
If Trim(ActiveCell.Value) <> "" Then
b_Excel_File_Has_Data = True
Do Until Trim(ActiveCell.Value) = ""
ActiveCell.Offset(1, 0).Select
i_rows_of_data = i_rows_of_data + 1
Loop
Else
b_Excel_File_Has_Data = False
End If
End If
Exit Sub
Err1:
MsgBox getName(str_Excel_Filename) & " is not a RTM template file."
b_abort = True
End Sub
Sub to enumerate all open workbooks
Sub List_Open_Workbooks(b_Excel_File_Has_Data As Boolean, i_rows_of_data As Integer)
Dim xlApp As Excel.Application
Set xlApp = GetObject(, "Excel.Application")
Dim str_filename As String
Dim xlWB As Excel.Workbook
If xlApp.Workbooks.Count = 0 Then
MsgBox "Error: Windows thinks there are no workbooks open in List_Open_Workbooks"
b_abort = True
Exit Sub
End If
For Each xlWB In xlApp.Workbooks
Debug.Print xlWB.Name
str_filename = getName(str_Excel_Filename)
If Trim(xlWB.Name) = Trim(str_filename) Then
xlWB.Activate
If xlWB Is Nothing Then
MsgBox "Workbook still not active in List_Open_Workbooks"
b_abort = True
Exit Sub
Else
' Sheets("RTM").Activate
Workbooks(xlWB.Name).Worksheets("RTM").range("First_Cell_For_Data").Select
range("First_Cell_For_Data").Select
If Trim(ActiveCell.Value) <> "" Then
b_Excel_File_Has_Data = True
Do Until Trim(ActiveCell.Value) = ""
ActiveCell.Offset(1, 0).Select
i_rows_of_data = i_rows_of_data + 1
Loop
Else
b_Excel_File_Has_Data = False
End If
End If
End If
Next xlWB
Set xlApp = Nothing
Set xlWB = Nothing
End Sub
Function to extract filename from path/filename
Function getName(pf)
getName = Split(Mid(pf, InStrRev(pf, "\") + 1), ".")(0) & ".xlsx"
End Function
I am hoping I found the source of my problem and solved it.
I believe that referring to an open workbook in sub using Dim wb_open As Object & Set wb_open = ActiveWorkbook in the Check_Excel_RTM_Template sub is causing my inconsistent problems....perhaps this is an anomoly (bug) in the VBA implementation in Word.
In the revised code I posted below I am passing the o_Excel object from the calling routine and using oExcel.Activesheet.xxx to reference ranges and values.
Now I next problem is that I am having errors on the form control button code which also uses the Dim wb_open As Object & Set wb_open = ActiveWorkbook approach to referring to the open workbook. But I'll post that as a new question.
Thanks to all who commented and provided suggestions.
Sub Check_Excel_RTM_Template(oExcel As Object)
Dim i_starting_row_for_data As Integer
Dim str_filename As String
i_rows_of_data = 0
On Error GoTo Err1:
oExcel.ActiveSheet.range("First_Cell_For_Data").Select
If Trim(oExcel.ActiveCell.Value) <> "" Then
b_Excel_File_Has_Data = True
Do Until Trim(oExcel.ActiveCell.Value) = ""
oExcel.ActiveCell.Offset(1, 0).Select
i_rows_of_data = i_rows_of_data + 1
Loop
Else
b_Excel_File_Has_Data = False
End If
Exit Sub
Err1:
Documents(str_doc_index).Activate
MsgBox getName(str_Excel_Filename) & " is not a RTM template file."
b_abort = True
End Sub
I'm building a code that will use a template (a Word doc embedded in Excel) and will find and replace certain words in the template using the inputs from Excel. I have successfully coded the opening of the template, find and replace in the template.
But after that, when I check the embedded Word doc in Excel, the replaced words were saved. I don't want to override the contents of the template but every time I run my code, it automatically saves the changes made during the find and replace. I just want it to find and replace, then save a copy to my local folder.
I'm using late binding as there is a limitation in the version of Excel that our team is using.
I don't know if the function of the below code is the one causing the changes to be saved in the embedded Word doc.
.Execute Replace:=2 'wdReplaceAll
Here is the my full code:
Sub Button1_Click()
Application.ScreenUpdating = False
Set WDApp = CreateObject("Word.Application")
WDApp.Visible = True
Set WDDoc = Sheets("Sheet1").OLEObjects("Template_112225")
WDDoc.Verb Verb:=xlOpen
WDApp.Selection.WholeStory
Call SplitCell
Call Find("<Part Num>", Sheets("Sheet2").Cells(8, 4).Value)
Call Find("<Dataset>", Sheets("Sheet2").Cells(7, 3).Value)
Call Find("<Letter>", Sheets("Sheet2").Cells(8, 5).Value)
Set WDDoc = Nothing
Set WDApp = Nothing
Set Rng = Nothing
End Sub
Sub Find(Find_Value As String, New_Value As String)
With WDApp.Selection.Find
.Text = Find_Value
.Replacement.Text = New_Value
.Forward = True
.Wrap = 1 'wdFindContinue
.Execute Replace:=2 'wdReplaceAll
End With
End Sub
Sub SplitCell()
Dim txt As String
Dim i As Integer
Dim NumberLetter As Variant
txt = Sheets("Sheet2").Cells(8, 3).Value
NumberLetter = Split(txt, "/")
For i = 0 To UBound(NumberLetter)
Cells(8, i + 4).Value = NumberLetter(i)
Next i
End Sub
Also is it possible to have a code that will make the Save As dialog box appear? So the user can have a choice on where to save the modified copy.
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