I am particularly new to coding, not to mention VBA. After a week of really cracking down on learning VBA, I've started to get the hang of it. At the moment, I'm trying to put together a code that will pull the hyperlinks (both addresses and names) out of a word document (eventually word, excel, and power point files), and dump them into the excel file I run the code from. It also dumps the file path and name at the top of the list. I can run the code and pull links from 1 file at a time, and the code pops it out after the end of the last filled line. It will save me endless amounts of time when I have to update links.
Sub ExtractWordLinks()
'the following code gets and sets an open file command bar for word documents
Dim Filter, Caption, SelectedFile As String
Dim Finalrow As String
Filter = "docx Files (*.docx),*.docx, doc Files (*.doc),*.doc, xlsm Files (*.xlsx),*.xlsx"
Caption = "Please Select .doc, .docx, .xlsx files only, " & TheUser
SelectedFile = Application.GetOpenFilename(Filter, , Caption)
'check if value is blank if it is exit
Finalrow = Cells(Rows.Count, 1).End(xlUp).Row
If (Trim(SelectedFile) = "") Then
Exit Sub
Else
'setting up the inital word application object
Set wordapp = CreateObject("word.Application")
'opening the document that is defined in the open file dialog
wordapp.documents.Open (SelectedFile)
'ability to change wether it needs to burn cycles updating the UI
wordapp.Visible = False
'declare excel sheet
Dim xlsSheet As Excel.Worksheet
'set active sheet
Set xlsSheet = Application.ActiveSheet
Dim i As Integer
i = 1
'MsgBox (wordapp.ActiveDocument.Hyperlinks.Count)
For i = 1 To wordapp.ActiveDocument.Hyperlinks.Count
'puts the title of the document in the formatted cells
'xlsSheet.Cells(Finalrow + 1, 1).Value = wordapp.ActiveDocument.Path & "\" & wordapp.ActiveDocument.Name
'formats the file name cell to be a bit easier to discern from the listing.
Range(Cells(Finalrow + 1, 1), Cells(Finalrow + 1, 2)).Font.Bold = True
Range(Cells(Finalrow + 1, 1), Cells(Finalrow + 1, 2)).Merge
'save the links address.
xlsSheet.Cells(Finalrow + i, 1).Value = wordapp.ActiveDocument.Hyperlinks(i).Address
'save the links display text
xlsSheet.Cells(Finalrow + i, 2).Value = wordapp.ActiveDocument.Hyperlinks(i).TextToDisplay
Next
wordapp.ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
wordapp.Quit SaveChanges:=wdDoNotSaveChanges
End If
End Sub
My problem, is that when I run this code on a simple sample file with 3 or so hyperlinks in it across a single page, it returns everything exactly how I want, with the file path/name at the top and all the links in the page directly below it (address in one column, displayed text in the other). However, when I run it on one of the files I am writing this code for (a 95+ page .docx file with ~30 links), it prints out the path/file in the formatted section, and then drops 90 (90 every time) blank lines before printing out the path/file a second time, and then all the links in the document. It does it perfectly, except for the inexplicable second path/file (even there if I comment out the bit I put in) and the 90 blank entries.
Can anyone explain what's going on, or should I try to figure out a way to just bypass the issue by removing my own link code, and including a bit that removes all blank lines?
Related
I was wondering that I can get some help with this code,
I am trying to download files from a website, the code I am using is
Public Sub DownloadFile()
Dim weblink As String
weblink = "https://documentflowmanagerus.abcabc.com/DFM_HBTC/Default.aspx?page=RetrDocView.aspx&URN="
Set Rng = Range("A1:A100")
For Each cell In Rng
'test if cell is empty
If cell.Value <> "" Then
link = weblink & cell.Value
ActiveWorkbook.FollowHyperlink Address:=link, NewWindow:=False
End If
Next
End Sub
this code is working alright, on the column A there is a list of all URN numbers where it loops,
this code loops through column A and goes to hyperlink to download file
the trouble is I have to save all the files manually , since each time it loops it opens a new tab in the browser
I am looking for a way that it closes the tab automatically and download file without manually saving it
I have a VBA program that automates assembly of Word documents from other docs using mostly copy/pasting and bookmark insertions. One template won't save after copying from another document. Here is the code that errors:
'get starting doc w macro (styletemplate)
Set mydoc = wrd.Documents.Open(strformattemplate, False, False)
'this is the base doc with styles - this save works fine
mydoc.SaveAs2 filename:=strNewName,FileFormat:=wdFormatXMLDocumentMacroEnabled
'here's our skeleton this is what we want to copy in
Set skel = wrd.Documents.Open(skelpath)
Set rangetocopy = skel.Range(0, skel.Bookmarks("\endofdoc").End)
rangetocopy.copy ' copy to clipboard
'copy in the skeleton and close it
Set workingrange = mydoc.Range(0, mydoc.Bookmarks("\endofdoc").End)
workingrange.Paste
mydoc.Save 'here's where it's failing
skel.Close False
The second save fails. There is an endless pop-up. The user must abort. I want to emphasize that this code works on all other templates. It appears to fail if one shape (a box that is an underline for a header) is included. Boxes like this appear in the first page of each chapter.
This is a question related to: Create text Files from every row in an Excel spreadsheet I have implemented ExactaBox great solution with the following code:
Sub SaveRowsAsENW()
Dim wb As Excel.Workbook, wbNew As Excel.Workbook
Dim wsSource As Excel.Worksheet, wsTemp As Excel.Worksheet
Dim r As Long, c As Long
Set wsSource = ThisWorkbook.Worksheets("worksheet1")
Application.DisplayAlerts = False 'will overwrite existing files without asking
r = 1
Do Until Len(Trim(wsSource.Cells(r, 1).Value)) = 0
ThisWorkbook.Worksheets.Add ThisWorkbook.Worksheets(1)
Set wsTemp = ThisWorkbook.Worksheets(1)
For c = 2 To 7
wsTemp.Cells((c - 1) * 2 - 1, 1).Value = wsSource.Cells(r, c).Value
Next c
wsTemp.Move
Set wbNew = ActiveWorkbook
Set wsTemp = wbNew.Worksheets(1)
'wbNew.SaveAs wsSource.Cells(r, 1).Value & ".csv", xlCSV 'old way
wbNew.SaveAs "textfile" & r & ".enw", xlCSV 'new way
'you can try other file formats listed at http://msdn.microsoft.com/en-us/library/office/aa194915(v=office.10).aspx
wbNew.Close
ThisWorkbook.Activate
r = r + 1
Loop
Application.DisplayAlerts = True
End Sub
Option Explicit
I have used this solution and it works fine. The only trouble I have is that some of the lines get quotation marks in the output file.
This is an example of output text file (line 2-3 demonstrates the error):
0 Journal Article 'No quotation marks
"%A Wofford, J.C."
"%A Goodwin, Vicki L."
%T A field study of a cognitive approach to understanding transformational and .. 'No quotation marks
This formatting seem to be added when it is being saved (it is not part of the cell formatting). Do any of you have any ideas of why this happens? /How can I adapt my code to fix it?
True. .csv stands for comma-separated values, where a field contains a comma it has to be 'escaped' (here with quotes) or would be split into different fields before/after each comma. Answer provided before does however offer alternatives - of which Tab delimited is the most logical.
This is likely past the point of being helpful to you, but after hitting this problem recently myself I thought I'd share my eventual solution. The formatting you're seeing is actually the result of a MS saving issue, which appends quotes to lines that have certain characters.
In my case I wrote out the file as usual and then called a sub that cleans the file of the problem extra characters. First I replaced any output that would need quotes with something like an asterisk or any other character that would never occur in my file. Then I saved the file as normal and called the below code, used to replace any character with another, twice. Once to remove the quotes Excel created, the second time to replace my dummy character with quotes. The code executes fairly quickly and renames the file so you can be certain the result is finished processing. Hopefully useful to others searching.
It's still clunkier than I'd like since you save a file and then edit it, but it worked well enough to become my final solution in the end.
Sub ReplaceStringInTextFile(FileNameAndLoc As String, OutFile As String, SearchForWords As String, SubstituteWords As String)
'This macro searches a file, replacing one string with another, saving it, and renaming it.
Dim objFSO As Object
Dim objReadFile As Object
Dim objWriteFile As Object
'Set Objects
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objReadFile = objFSO.opentextfile(FileNameAndLoc, 1, False)
'Read file contents
Contents = objReadFile.readall
'Close read file
objReadFile.Close
'Copy contents without double quotes
NewContents = Replace(Contents, SearchForWords, SubstituteWords)
'Write output
Set objWriteFile = objFSO.opentextfile(FileNameAndLoc, 2, False)
objWriteFile.write NewContents
objWriteFile.Close
'Rename file
Name FileNameAndLoc As OutFile
End Sub
I'm currently writing up a macro which compares the contents of a word document against text dictionary file. It highlights all the matches so that the person can make appropriate changes. I'm a little new to macros so I used something similar I found online as a guide as well as my general coding knowhow but I don't know all the methods and objects that I need to.
I have set it up to open a common dialog to choose a word file to compare (the dictionary file is hard coded because I don't want people accidentally choosing one as it could potentially be used by a lot of people)
For each line in the dictionary file, the macro uses the hithighlight method to highlight any occurences of that word in the file. I had to put spaces around the word to make sure only individual words were done since the dictionary contained many acronyms.
The issue is I therefore had to pad the document with spaces at the start and end so that the first and last words are also checked, I'm not sure how to do this though. I've done some searching and I've seen a few things about using different selections but I don't know if there's a clone method for selections and I'm sure if I set another selection as equal to mine it'd just copy the address to the object which would make it pointless.
this is the code I have:
Documents(ActiveDocument.FullName).Close SaveChanges:=wdDoNotSaveChanges
'Values for objFSO
Const ForReading = 1
Const ColourYellow = 65535
Dim doc As Document
Dim DocRange As Range
'allows us to change the document in use
Set ObjCD = CreateObject("UserAccounts.CommonDialog")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("WScript.Shell")
'Relevant path to the Dictionary txt file, change this to point to the dictionary list if different to this
DicFilePath = "O:\IPS\PDU\KIS\Intranet\consistency-with-styleguide-project\styleguidelist.txt"
'Set the parameters for the Common Dialog
ObjCD.Filter = "Word Documents|*.docx" 'Filter only docx files
ObjCD.FilterIndex = 3
ObjCD.InitialDir = "" 'Set the initial path for the Common Dialog to the same folder as the script
'Display the File open dialog
InitFSO = ObjCD.ShowOpen
If InitFSO = False Then
'No file was selected so Error
MsgBox ("No file was selected")
Else
'ScanFilePath = the full path and filename if the file
ScanFilePath = ObjCD.FileName
Set doc = Documents.Open(ScanFilePath) 'store the document we want to check as doc
Set objDicFile = objFSO.OpenTextFile(DicFilePath, ForReading) 'open the dictionary file
With doc
MatchFound = False 'initially have no matches found as haven't searched yet
Set DocRange = .Range 'this represents the entire document
DicWordCount = 0
DocRange.InsertAfter (Space(1))
DocRange.InsertBefore (Space(1))
'do this to pad the start and end with spaces to allow matches for the first and last word
'this is done as it's easier than having it look for start and end of file markers and still only find
'whole words
'Loop though each word in the dictionary and check if that word exists in the word doc
Do While objDicFile.AtEndOfStream <> True
'reset so EACH word in dictionary is checked for
DicWordFound = False
'Read the next word from the dictionary
DicWord = objDicFile.ReadLine
DicWord = Space(1) & DicWord & Space(1) 'add a space to both sides to find whole words only
DicWordFound = DocRange.Find.HitHighlight(DicWord, ColourYellow)
'is true if it was found at least once, else false. If any are found they are highlighted in yellow
If DicWordFound Then
MatchFound = True 'MatchFound if used to check if any match was found for any words, only false if none are found
End If
Loop
'this is done to remove the superfluous space at the end.
End With
If MatchFound Then
'If a Match is found
'Display OK message
MsgBox ("Complete: MATCH FOUND!" & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "Matches are highlighted in yellow.")
Else
'If a Match is NOT found
MsgBox ("No Match")
End If
End If
if someone knows how I could remove the padding I added once I'm done searching that would be really helpful. Alternatively, if someone could suggest a more efficient way it would be greatly appreciated. (for instance, I'm sure there should be a way to check for whole words only when searching but I don't know it as I'm new to macros)
Also if someone knows for sure if the same functionality is replicated in word 97-2003 using the same methods and objects let me know, that way I can just extend it to .doc files without any extra word.
Thanks for your time.
You can try to record macros, this can help finding objects or method when you can't choose which is the right one.
In your case, you could use the .MatchWholeWord property of the Find object (http://msdn.microsoft.com/en-us/library/bb226067.aspx) :
DicWordFound = DocRange.Find.HitHighlight(DicWord, ColourYellow, MatchWholeWord = True)
Could not check it right here though.
Hope that helps,
Regards,
Max
My question is as follows:
I have given a workbook to multiple people. They have this workbook in a folder of their choice. The workbook name is the same for all people, but folder locations vary.
Let's assume the common file name is MyData-1.xls.
Now I have updated the workbook and want to give it to these people. However when they receive the new one (let's call it MyData-2.xls) I want specific parts of their data pulled from their file (MyData-1) and automatically put into the new one provided (MyData-2).
The columns and cells to be copied/imported are identical for both workbooks. Let's assume I want to import cell data (values only) from MyData-1.xls, Sheet 1, cells B8 through C25 ... to ... the same location in the MyData-2.xls workbook. How can I specify in code (possibly attached to a macro driven import data now button) that I want this data brought into this new workbook. I have tried it at my own location by opening the two workbooks and using the copy/paste-special with links process. It works really well, but It seems to create a hard link between the two physical workbooks. I changed the name of the source workbook and it still worked. This makes me believe that there is a "hard link" between the tow and that this will not allow me to give the target (MyData-2.xls) workbook to others and have it find their source workbook.
To clarify my understanding, each user has a spreadsheet called MyData-1.xls but with varying locations. You would like to send each person a new spreadsheet MyData-2 which will automatically pull in data from range B8:C25 in MyData-1.xls?
There are various options on doing this and below I have provided one way of doing this. In short, the user will open MyData-2, click a button, and the code will search for MyData-1 on their directory, open the workbook, grab the data, paste it into MyData-2, and then close MyData-1.
Sub UpdateWorkbook()
'Identify workbook you would like to pull data from (same for all users)
Dim TargetWorkbook As String
TargetWorkbook = "MyData-1"
'Get the full path of that workbook by searching in a specified directory
Dim TargetPathName As String
TargetPathName = GetFilePath(TargetWorkbook)
'Retrieve data in range B8:C25, copy and paste, then close workbook
Dim TargetRng As Range
Application.ScreenUpdating = False
Workbooks.Open Filename:=TargetPathName
Set TargetRng = Sheets("Sheet1").Range("B8:C25")
TargetRng.Copy Destination:=ThisWorkbook.Worksheets(1).Range("B8:C25")
ActiveWorkbook.Close
Application.ScreenUpdating = True
End Sub
Function GetFilePath(TargetWkbook As String) As String
Dim FullFilePath As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
With Application.FileSearch
.NewSearch
.LookIn = "C:\"
.FileType = msoFileTypeExcelWorkbooks
.SearchSubFolders = True
.Filename = TargetWkbook
If .Execute > 0 Then
FullFilePath = .FoundFiles(1)
End If
End With
GetFilePath = FullFilePath
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Function
By way of explanation:
In the sub you first need to specify the name of the workbook MyData-1
The Function GetFilePath will then get the full path name of the workbbok. Note that I have set it to look in the "C:\" drive and you may want to amend that
Once we have the full file path we can easily open the workbook and copy the required range.
Note that the screenupdating is turned off to create the 'illusion' that the workbook has not been opened when the data is copied. Also, I have added a button on the worksheet of MyData-2 to trigger the code i.e. user opens workbook, presses button, and data is imported.
Finally, this code could be augmented significantly and you may want to tweak it. For example, error checking if file not found, searching in multiple directories (e.g C:\, D:)...
Hope this gets you started on the right track
You should use the copy/paste-special for values only:
Private Sub ImportData_Click()
On Error GoTo OpenTheSheet
Workbooks("MyData-1.xls").Activate
GoTo SheetOpen
OpenTheSheet:
Workbooks.Open "MyData-1.xls"
Workbooks("MyData-1.xls").Activate
SheetOpen:
On Error GoTo 0
Workbooks("MyData-1.xls").Worksheets("sheetwhatever").firstRange.Copy
Workbooks("MyData-2.xls").Worksheets("anothersheet").yourRange.PasteSpecial(xlPasteValues)
End Sub
This could be cleaned up a bit, but it's always messy to do file stuff in VBA, I'd probably put the opening code in a function.
Make sure they put the new file in the same directory as the old file.