I have a lot of cells with hyperlink function. One example: A1=HYPERLINK("T:\projekt1\61VWAus.xlsx";"61VWAus.xlsx" ). I need go through each cell and check each hyperlink if it is valid file. How can I get the hyperlink "T:\projekt1\61VWAus.xlsx" to a variable from the formula value? Do I have to use string operation to get it or is there any direct function to get only hyperlink?
Thanks
I have found the solution:
Function check_hyperlink(rng As Range) As Boolean
Dim oFSO As Object
Dim str_Hyperlink As String
Dim exists As Boolean
Dim str_form As String
Dim arr_str_form As Variant
Set oFSO = CreateObject("Scripting.FileSystemObject")
str_form = rng.Cells(1, 1).Formula
If Left(str_form, 10) = "=HYPERLINK" Then
arr_str_form = Split(str_form, Chr(34))
str_Hyperlink = arr_str_form(1)
exists = oFSO.FileExists(str_Hyperlink)
If exists Then
check_hyperlink = True
Else
check_hyperlink = False
End If
Else
check_hyperlink = False
End If
End Function
Related
I have been creating a macro in excel that will pull information from an excel sheet and insert into a word document.
After much trial and error I have managed to get it to insert all the information I want but I am now stuck on changing the formatting of what is inserted.
After trying a number of different ways to change the formatting inside the macro (none of which worked) I settled on creating a number of functions in word VBA to make the formatting changes I wanted (I.E Change to a style, bold or format to bullet points). These functions work in word with zero problems. But whenever I call them from the excel macro I get a Run-time error '438' Object doesn't support this property or method. I double and triple checked I have the word object library ticked, at this stage I'm assuming I'm doing something an excel object doesn't like but for the life of me I can not figure out where the issues is.
Here is a small section of the excel macro, if I run it without calling the word function it works fine. I have tried putting the call inside a with wrdApp with no luck. I also tried pulling it outside of the with wrdDoc but that didn't work either.
Sub ExportData()
'
' ExportData Macro
' Export the data from excel into a more usable form in word
'
Dim sheetcounter As Integer
Dim counter As Integer
Dim numbsheets As Integer
Dim numbepisodes As Integer
Dim wrdApp As Object, wrdDoc As Object
Dim episodetitle As String
Dim nextepisodetitle As String
Dim season As Variant
Dim series As String
Dim episodenumber As String
Dim releasedate As Variant
Dim length As String
Dim fndDay As Integer
Dim fndMnth As Integer
Dim hrs As String
Dim mns As String
Dim scs As String
Dim lnglgth As String
Dim sheetname As String
Dim myRange As Range
Dim lookupRange As Range
Dim datarng As Range
Dim text As Range
Set wrdApp = CreateWord
Set wrdDoc = wrdApp.Documents.Add
With wrdDoc
numbsheets = Application.Sheets.Count
.Content.ParagraphFormat.SpaceBefore = 0
.Content.ParagraphFormat.SpaceAfter = 0
.Content.InsertAfter "Internal Wiki"
Call wrdApp.cntrl("Internal Wiki", "Style", "Title")
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
Here is the cntrl word function
Public Function cntrl(txt As String, fnctn As String, optn As String, Optional optnsize As Integer) as Object
'
' A function to control the word functions from excel
'
'
Dim myRange As Range
Set myRange = fndtxt(txt)
If fnctn = "Style" Then
Call Style(myRange, optn)
ElseIf fnctn = "List" Then
Call List(myRange, optn)
ElseIf fnctn = "Format" Then
If IsMissing(optnsize) Then
Call format(myRange, optn)
Else
Call format(myRange, optn, optnsize)
End If
End If
End Function
The fnd txt function
Public Function fndtxt(txt As String) As Range
'
' A function to find text and return it as a range. To be used in combination with the formatting funcitons
'
'
Set fndtxt = ActiveDocument.Range
With fndtxt.Find
.text = txt
.Forward = True
.Execute
End With
End Function
And the style function.
Public Function Style(txt As Range, stylename As String) As Object
'
' A function to apply styles to ranges
'
'
Dim myRange As Range
Set myRange = txt
myRange.Style = stylename
End Function
I split them out into individual functions so I could use them separately if I wanted or together in the control function. I am sure this is not the most efficient way but after working on this for 3 days straight I needed to split things up or I was going to have an aneurism. To be through I tried them as sub's instead of functions and got the same error.
I get the same error for all the formatting functions, I just focused on the style one as this seemed the best way to simplify things and make it easier to explain :). Quite happy to post those as well if required.
Sorry if this has been answered, I had a look through the forums but could not see anything like this.
Would appreciate any and all help this is driving me insane.
EDIT:
Thank you very to much to Tim this is now working, here is the changed and working code. I moved the funcs into excel and you can find them below.
Excel Macro
Sub ExportData()
'
' ExportData Macro
' Export the data from excel into a more usable form in word
'
Dim sheetcounter As Integer
Dim counter As Integer
Dim numbsheets As Integer
Dim numbepisodes As Integer
Dim wrdApp As Object, wrdDoc As Object
Dim episodetitle As String
Dim nextepisodetitle As String
Dim season As Variant
Dim series As String
Dim episodenumber As String
Dim releasedate As Variant
Dim length As String
Dim fndDay As Integer
Dim fndMnth As Integer
Dim hrs As String
Dim mns As String
Dim scs As String
Dim lnglgth As String
Dim sheetname As String
Dim myRange As Range
Dim lookupRange As Range
Dim datarng As Range
Dim text As Range
Set wrdApp = Createword
Set wrdDoc = wrdApp.Documents.Add
With wrdDoc
numbsheets = Application.Sheets.Count
.Content.ParagraphFormat.SpaceBefore = 0
.Content.ParagraphFormat.SpaceAfter = 0
.Content.InsertAfter "DnD is for Nerds Wiki"
Call cntrl(wrdDoc, "DnD is for Nerds Wiki", "Style", "Title")
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
The cntrl function
Public Function cntrl(doc As Word.Document, txt As String, fnctn As String, optn As String, Optional optnsize As Integer) As Object
'
' A function to control the word funcitons from excel
'
'
Dim myRange As Word.Range
Set myRange = fndtxt(doc, txt)
If fnctn = "Style" Then
Call Style(myRange, optn)
ElseIf fnctn = "List" Then
Call List(myRange, optn)
ElseIf fnctn = "Format" Then
If IsMissing(optnsize) Then
Call format(myRange, optn)
Else
Call format(myRange, optn, optnsize)
End If
End If
End Function
The fndtxt function
Public Function fndtxt(doc As Word.Document, txt As String) As Word.Range
'
' A function to find text and return it as a range. To be used in combination with the formatting funcitons
'
'
Dim rng As Word.Range
Set rng = doc.Range
With rng.Find
.text = txt
.Forward = True
.Execute
End With
Set fndtxt = rng
End Function
The Style function
Public Function Style(txt As Word.Range, stylename As String) As Object
'
' A function to apply styles to ranges
'
'
Dim myRange As Word.Range
Set myRange = txt
myRange.Style = stylename
End Function
A lot of it came down to adding the word. in front of the ranges.
Here's a basic example with all the code on the Excel side:
Sub Tester()
Dim wdApp As Word.Application, doc As Word.Document, rng As Word.Range
Set wdApp = GetObject(, "Word.Application") 'in my testing word is already open
Set doc = wdApp.Documents.Add()
With doc
.Content.ParagraphFormat.SpaceBefore = 0
.Content.ParagraphFormat.SpaceAfter = 0
.Content.InsertAfter "Internal Wiki"
SetTextStyle doc, "Internal Wiki", "Title"
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
End With
End Sub
Sub SetTextStyle(doc As Word.Document, txt As String, theStyle As String)
Dim rng As Word.Range
Set rng = WordTextRange(doc, txt)
If Not rng Is Nothing Then
rng.style = theStyle
Else
MsgBox "'" & txt & "' was not found", vbExclamation
End If
End Sub
'return a range containing the text `txt` in document `doc`
' returns Nothing if no match is made
Function WordTextRange(doc As Word.Document, txt As String) As Word.Range
Dim rng As Word.Range
Set rng = doc.Range
With rng.Find
.Text = txt
.Forward = True
If .Execute() Then 'check that Execute succeeds...
Set WordTextRange = rng
End If
End With
End Function
I have the following code:
Sub AddSources()
Dim pubPage As Page
Dim pubShape As Shape
Dim hprlink As Hyperlink
Dim origAddress() As String
Dim exportFileName As String
exportFileName = "TestResume"
Dim linkSource As String
linkSource = "TestSource2"
Dim hyperLinkText As TextRange
For Each pubPage In ActiveDocument.Pages
For Each pubShape In pubPage.Shapes
If pubShape.Type = pbTextFrame Then
For Each hprlink In pubShape.TextFrame.TextRange.Hyperlinks
If InStr(hprlink.Address, "http://bleaney.ca") > 0 Then
hyperLinkText = hprlink.Range
origAddress = Split(hprlink.Address, "?source=")
hprlink.Address = origAddress(0) + "?source=" + linkSource
hprlink.Range = hyperLinkText
End If
Next hprlink
End If
Next pubShape
Next pubPage
ThisDocument.ExportAsFixedFormat pbFixedFormatTypePDF, "C:\" + exportFileName + ".pdf"
End Sub
I am getting the "Object variable or With block variable not set (Error 91)" error on the line with hyperLinkText = hprlink.Range. When I debug I can see that hprlink.Range does have a value. Any thoughts what I'm doing wrong?
As I wrote in my comment, the solution to your problem is to write the following:
Set hyperLinkText = hprlink.Range
Set is needed because TextRange is a class, so hyperLinkText is an object; as such, if you want to assign it, you need to make it point to the actual object that you need.
I want to run a macro that brings me the following value INTERVAL_PERCENT_CHANGE from:
The ticher of the fund concerned S3.Range(Cells(3, 76), Cells(3, 77)).
Start and end dates S3.Cells(i, 73).Value and S3.Cells(i, 74).Value
Currency S3.Cells(2, 76).Value
from the Bloomberg APIs. But I get a soft error message
"invalid procedure call or argument".
I really tried everything but there is something that escapes me.
the underlined line is the following:
range(cells(4,76),cells(12,77)).value msg.GetElement("securitydata").GetValue(0).GetElement("fieldData").GetElement("INTERVAL_PERCENT_CHANGE").Value
Thank you for all your answers and insights. below the code in full
Sub ref_data()
Dim session As blpapicomLib2.session
Set session = New session
session.Start
Dim Service As blpapicomLib2.Service
session.OpenService ("//blp/refdata")
Set Service = session.GetService("//blp/refdata")
Dim Request As blpapicomLib2.Request
Set Request = Service.CreateRequest("ReferenceDataRequest")
Request.Append "securities", "S3.Range(Cells(3, 76), Cells(3, 77)).Value"
Request.Append "fields", "INTERVAL_PERCENT_CHANGE"
Dim overrides As Element
Set overrides = Request.GetElement("overrides")
Dim override As Element
Set override = overrides.AppendElment
Dim i As Integer
For i = 4 To 12
Dim override1 As Element
Set override1 = overrides.AppendElment
override1.SetElement "fieldId", "Start_Date_Override"
override1.SetElement "value", "S3.Cells(i, 73).Value" 'Replace date with the cell reference eg Range("B10").Value
Dim override2 As Element
Set override2 = overrides.AppendElment
override2.SetElement "fieldId", "End_Date_Override"
override2.SetElement "value", "S3.Cells(i, 74).Value" 'Replace date with the cell reference eg Range("A10").Value
Dim override3 As Element
Set override3 = overrides.AppendElment
override3.SetElement "fieldId", "CRNCY"
override3.SetElement "value", "S3.Cells(2, 76).Value" 'Replace EUR with the cell reference eg Range("A10").Value
session.SendRequest Request
Dim blpevent As blpapicomLib2.Event
Dim it As blpapicomLib2.MessageIterator
Dim msg As blpapicomLib2.Message
Dim finalResponse As Boolean
Do While finalResponse = False
Set blpevent = session.NextEvent
Set it = blpevent.CreateMessageIterator
Do While it.Next
Set msg = it.Message
If blpevent.EventType = RESPONSE Or blpevent.EventType = PARTIAL_RESPONSE Then
range(cells(4,76),cells(12,77)).value msg.GetElement("securitydata").GetValue(0).GetElement("fieldData").GetElement("INTERVAL_PERCENT_CHANGE").Value
End If
If blpevent.EventType = RESPONSE Then
finalResponse = True
End If
Loop
Loop
Next i
End Sub
I have a column in a spreadsheet.
The format of the data in each cell is aa-0001-xx.
I need to examine the whole column to find the highest value of the sequence number. this would be the substring from column4 thru column7.
I can find the sequence number using Mid(ActiveWorkbook.Sheets("Sheet1").Range("B2:B2"), 4, 4)
But I need to find the max sequence in the whole column.
I am doing this in VBA.
Any help would be appreciated.
Here is my code so far:
Private Sub CommandButton1_Click()
Dim sQuoteNumber As String
Dim sFileName As String
Dim sPathName As String
Dim checkit As String
'Log the Quote
'First, open the log file and determine the next sequential log number.
sPathName = "C:\Users\Rich\Documents\Bryan\BigProject\"
sFileName = "QuoteLog2016.xlsx"
ControlFile = ActiveWorkbook.Name
Workbooks.Open Filename:=sPathName & sFileName
'Create the new Quote Number
checkit = Mid(ActiveWorkbook.Sheets("Sheet1").Range("B2:B2"), 4, 4) ' This is a temp test line
If Mid(ActiveWorkbook.Sheets("Sheet1").Range("B2:B2"), 4, 4) = "" Then
sQuoteNumber = "16-0001"
Else
'find the biggest number
'Here I was looking to like pass the mid function to a Max function of some sort.
sQuoteNumber = "16-0002"
End If
MsgBox ("The new Quote Number is: " + sQuoteNumber)
'Save the log entry
Workbooks(sFileName).Close
All of the comments made to your answer would work well for you. It's also true that there's no evidence in your code at having attempted something, however rudimentary, and this is why answers to a rather trivial task are not forthcoming for you. Perhaps, in future, have a go at some kind of solution ( even if it feels more guesswork than anything) and people on this site will be much more supportive of you.
To set you on your way, you could make use of the Split() function which converts a String into a String array, separated by a nominated value - in the case of your quotations, you could use "-" as your separator. This might be easier than your Mid function and will deal with the case of different sized quotations.
The code below will get you started but you'd want some error handling in there to test, for example, that each cell splits appropriately or that any cells aren't blank. I'll leave all of that to you.
Option Explicit
Private mLastQuote As Long
Public Sub Test()
Initialise 'call this routine just once at the start of your project
MsgBox GetNextQuote(16) 'use the GetNextQuote() function to get next number
MsgBox GetNextQuote(16)
MsgBox GetNextQuote(16)
End Sub
Private Function GetNextQuote(prefix As Integer) As String
mLastQuote = mLastQuote + 1
GetNextQuote = CStr(prefix) & "-" & _
Format(mLastQuote, "000#")
End Function
Private Sub Initialise()
Const PATH_NAME As String = "C:\Users\Rich\Documents\Bryan\BigProject\"
Const FILE_NAME As String = "QuoteLog2016.xlsx"
Const QUOTE_COL As String = "B"
Dim wb As Workbook
Dim ws As Worksheet
Dim v As Variant
Dim r As Long
Dim parts() As String
Dim num As Long
Application.ScreenUpdating = False
Set wb = Workbooks.Open(PATH_NAME & FILE_NAME, True, True)
Set ws = wb.Worksheets("Sheet1")
'Read quote values into variant array
With ws
v = .Range(.Cells(2, QUOTE_COL), _
.Cells(.Rows.Count, QUOTE_COL).End(xlUp)) _
.Value2
End With
'Find max quote
For r = 1 To UBound(v, 1)
parts = Split(v(r, 1), "-") 'splits quote into 3 parts
num = CLng(parts(1)) 'index (1) is the middle part
If num > mLastQuote Then mLastQuote = num
Next
wb.Close False
Application.ScreenUpdating = True
End Sub
Is it possible to pass a variable into the .range property?
I would like the following function to work, but I can't seem to get it to work. My guess is it is something to do with how I'm calling the range property.
function computeNVEndTime()
Dim lastTime As Range
Dim totalTimes As Integer
Dim prod As New ProductionWebObj
dim ws as WorkSheet
set ws = ActiveSheet
totalTimes = prod.FindNumberOfRanges("time")
Set lastTime = ws.Range("time_" & totalTimes)
If isEmptyString(lastTime) Then
computeNVEndTime = ""
Else: computeNVEndTime = lastTime.Value
End If
End Function
It appears that totalTimes was returning 0 instead of 10, like I expected. The named ranges were not on the "ActiveSheet," but the next sheet over. Thanks for your help #TimWilliams and #peege!