Cannot use named range when it is empty - vba

I have a named range lstVendors that refers to: =OFFSET(Data!$W$2,0,0,COUNTA(Data!$W$2:$W$400),1). I want this range to be populated when the workbook opens. I have the following code for this:
Private Sub Workbook_Open()
Application.WindowState = xlMaximized
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
ThisWorkbook.Sheets("Dashboard").Shapes("TextBox 6").Visible = False
' Range("lstVendors").Offset(0, 0).Value = "Please Select..."
' Set DropDown1 = ThisWorkbook.Sheets("Dashboard").DropDowns("Drop Down 1")
' DropDown1.Value = 1
On Error Resume Next
If Not IsError(Range("lstVendors")) Then
Range("lstVendors").ClearContents
End If
On Error GoTo 0
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
Set startRng = Range("lstVendors")
i = 0
For n = 2 To UBound(rslt)
Range("lstVendors").Offset(i, 0).Value = rslt(n)(0)
i = i + 1
Next n
End Sub
It errors on the Set startRng = Range("lstVendors"). I know this is because there's nothing in the range when I'm trying to set it, because if I put one entry into the named range, the set works, however, I need it populated by the sqlite query on each open as the data changes.
Any suggestions much appreciated.

Try this. You have a dynamic range that doesn't evaluate after you clear the contents. To avoid this, there are probably several ways, but easy to simply hardcode the startRange variable so that it always points to Data!$W$2 address, which is (or rather, will become) the first cell in your lstVendors range.
Private Sub Workbook_Open()
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
Dim rngList As Range
'// Define your startRange -- always will be the first cell in your named range "lstVendors"
' hardcode the address because the dynamic range may not evalaute.
Set startRange = Sheets("Data").Range("W2")
'// Empty th lstVendors range if it exists/filled
On Error Resume Next
Range("lstVendors").Clear
On Error GoTo 0
'// Run your SQL query
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
i = 0
'// Print results to the Worksheet, beginning in the startRange cell
For n = 2 To UBound(rslt)
'Increment from the startRange cell
startRange.Offset(i, 0).Value = rslt(n)(0)
i = i + 1
'Verify that "lstVendors" is being populated
Debug.Print Range("lstVendors").Address
Next n
End Sub

Thanks for the suggestions. Here is what I ended up doing in order to get around my problem. It involves adding something I didn't specify would be ok in my original question, so David's answer is great if what I did isn't an option. I first populated the first two cells in my named range with "Please Select..." and "All". In Sub Workbook_Open() we do this:
Private Sub Workbook_Open()
Application.WindowState = xlMaximized
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
' Disable our not found message
ThisWorkbook.Sheets("Dashboard").Shapes("TextBox 6").Visible = False
' Set our start range to our named range
Set startRng = Range("lstVendors")
' Grab all vendor names
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
' Print result. Skip first two rows as constants "Please Select..." and "All" are populated there
i = 2
For n = 2 To UBound(rslt)
startRng.Offset(i, 0).Value = rslt(n)(0)
i = i + 1
Next n
End Sub
Then we will create Sub Workbook_BeforeClose:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' Disable the save changes dialog. This workbook will be locked up for display only. No need to confuse the user.
Application.DisplayAlerts = False
' Clear everything below the "Please Select..." and "All" cells in the named range
On Error Resume Next
Range("lstVendors").Offset(2, 0).ClearContents
On Error GoTo 0
' Save the changes to the named range
ThisWorkbook.Save
Application.DisplayAlerts = True
End Sub
This information is going to populate a drop down, so having Please Select and All hardcoded into the named range is acceptable for me. If that stipulation doesn't work for someone else looking at this in the future, please use David's suggestion! Thanks again!

Related

Search if value in cell (i,j) exists in another sheets, else i+1 until same value is found

I have an issue with my VBA script which I'm not able to resolve, despite of all the researches I've made (Indeed, I tried to modify all the vba scripts which were near what I'm looking for, but it doesn't work).
Thank you very much for your help !
I have 2 sheets.
For the first one (ActiveSheet), I have a list.
For example :
Beurre
Creme fraiche
Fromage
Oeufs
Yaourts
In the second one ("Add value"), I have this list :
Chocolat
Carotte
Haricot
Fromage
Endive
I want the script to verify if the first value which is the sheet ("Add Value") exists in the ActiveSheet.
If it doesn't, it takes the second value in "Add Value" to make this verification. And so on with the other lines.
The loop has to stop when the script finds the same value. Then it does an action (MsgBox, for example).
For example, when the script researches "Chocolat" (the first line of the sheet "Add Value") in the ActiveSheet, it won't find it : it will use the second word to make this reasearch until it uses world "Fromage" which also exist in the second sheet.
It does the action (the msgbox), then quit the loop to continue with the other called macro which are in the script.
Moreover, I would like to choose the columns of the cell from "Add Value" each time I call the macro. Indeed, there will be several lists in this sheet.
Here is my macro. The issue is that I get the error 424 on the ligne If Not FindString Is Nothing Then
Public Sub Var()
Dim plage As Variant
Set plage = ActiveSheet.Range("A:A")
Dim col As Integer
Dim Ligne As Integer
Set Ligne = 2
Dim FindString As String
Set FindString = ThisWorkbook.Sheets("Add Value").Cells(Ligne, col).Value
End Sub
Sub Boucle_Ajout(col)
With plage
Do
If Not FindString Is Nothing Then
'do
Else
Ligne = Ligne + 1
End If
Loop While Not FindString Is Nothing
End With
End Sub
Then when I call the Macro, I only have to choose the column.
For example :
Call Boucle_Ajout(1)
Thank you very much for your help, because I am sick of not finding the solution.
PS : sorry for my english, I'm french.
Assuming the lines without numbers are in A1 to A5, this works:
Option Explicit
Const THECOLUMN = "A1"
Sub FindLineInOtherSheet()
Dim activeSheetRange As Range
Dim addValueRange As Range
Dim activeSheetLastRow As Integer
Dim addValueLastRow As Integer
Dim i As Integer
Dim n As Integer
Dim activeSheetCell As String
Dim addValueCell As String
'*
'* Setup
'*
Set activeSheetRange = ThisWorkbook.Sheets("activeSheet").Range(THECOLUMN)
activeSheetLastRow = findLastRow("activeSheet", THECOLUMN)
addValueLastRow = findLastRow("addValue", THECOLUMN)
'*
'* Loop through each cell in addValue for each cell in activeSheet
'*
For i = 1 To activeSheetLastRow
Set addValueRange = ThisWorkbook.Sheets("addValue").Range(THECOLUMN)
activeSheetCell = activeSheetRange.Value
For n = 1 To addValueLastRow
addValueCell = addValueRange.Value
If addValueCell = activeSheetCell Then
MsgBox ("Trouvé " & addValueCell)
End If
Set addValueRange = addValueRange.Offset(1, 0) 'Next row
Next n
Set activeSheetRange = activeSheetRange.Offset(1, 0)
Next i
End Sub
Function findLastRow(Sheetname As String, ColumnName As String) As Integer
Dim lastRow As Integer
Dim r As Range
Dim WS As Worksheet
Set WS = Worksheets(Sheetname)
lastRow = WS.UsedRange.Rows.Count
'*
'* Search backwards till we find a cell that is not empty
'*
Set r = WS.Range(ColumnName).Rows(lastRow)
While IsEmpty(r)
Set r = r.Offset(-1, 0)
Wend
lastRow = r.Row
Set WS = Nothing
findLastRow = lastRow
End Function

Changing value of a cell based on the value of two cells - VBA Excel

I am trying to add some automation to a spreadsheet by changing the value of cells in one column based on the value in that column and one other. I have got the code below so far. If I use .text the code runs through fine but makes no changes to the values of the cells. If I use .value I get this error message:
Run-time error '13: Type mismatch
Please could someone advise on what I am doing wrong here.
Sub change_orrtime_4()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'For Each employee In Range("Timesheet_RawData[Employee]")
Dim employee As Range
Dim datefield As Range
Dim tbl As ListObject
Dim tRows As Long
Dim tCols As Long
Dim i As Long
Set tbl = Sheets("Timesheet Data").ListObjects("Timesheet_RawData")
With tbl.DataBodyRange
tRows = .Rows.Count
' tCols = .Colummns.Count
End With
With Sheets("Timesheet Data")
Set employee = Sheets("Timesheet Data").Range("Timesheet_RawData[Employee]")
Set datefield = Sheets("Timesheet Data").Range("Timesheet_RawData[Date]")
End With
With Sheets("Timesheet Data")
For i = 2 To tRows
If employee.Value = "Some Name" And datefield.Value = "1" Then ' type mismatch doesnt occur with .text but then nothing works
employee.Value = "Some Name_SomeTeam"
End If
Next i
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
you're setting employee (and datefield, too) to multiple cells ranges, therefore you can't access it Value property, while you can access it Text property that would return a text if all cells share that same text or otherwise a Null
so you have to point at the specific cell in that range, like:
employee(i).Value
finally you could refactor your code a little as follows:
Sub change_orrtime_4()
Dim employee As Range
Dim datefield As Range
Dim tRows As Long
Dim tCols As Long
Dim i As Long
With Sheets("Timesheet Data")
With .ListObjects("Timesheet_RawData")
With .DataBodyRange
tRows = .Rows.Count
' tCols = .Colummns.Count
End With
Set employee = .ListColumns("Employee").DataBodyRange
Set datefield = .ListColumns("Date").DataBodyRange
End With
For i = 1 To tRows
If employee(i).Value = "Some Name" And datefield(i).Value = "1" Then employee(i).Value = "Some Name_SomeTeam"
Next i
End With
End Sub

Copy named ranges to the active sheet

I'm trying to copy named ranges from the Wk1 worksheet to the active sheet in the workbook.
I keep getting error messages when I run the code. They either say an Object is not set or a variable has not been declared.
Sub ChangeNamedRangesOnNewWKsheet()
Dim RangeName As Name
Dim HighlightRange As Range
Dim RangeName2 As String
Dim NewRangeName As String
Dim Ws As Worksheets
Dim cs As Worksheet
Set cs = Application.ActiveSheet
''''' Delete invalid named ranges
For Each RangeName In ActiveWorkbook.Names
If InStr(1, RangeName.RefersTo, "#REF!") > 0 Then
RangeName.Delete
End If
Next RangeName
For Each RangeName In Ws
If InStr(1, RangeName, "Wk1", 1) > 0 Then
Set HighlightRange = RangeName.RefersToRange
NewRangeName = Replace(RangeName.Name, "Wk1", "cs.Name")
RangeName2 = Replace(RangeName, "='Wk1'", "'cs.Name'")
On Error Resume Next
HighlightRange.Copy Destination:=Worksheets("cs.Name").Range(RangeName2)
Range(RangeName2).Name = NewRangeName
On Error GoTo 0
End If
Next RangeName
MsgBox "Done"
End Sub
Ive changed the code to this. Im not getting error messages but the code is still not working. the named ranges are not copying from the Wk1 sheet to the Active sheet. The only thing that happens is that the Message Box Opens
Sub ChangeNamedRangesOnNewWKsheet()
Dim RangeName As Name
Dim HighlightRange As Range
Dim RangeName2 As String
Dim NewRangeName As String
Dim Cs As Worksheet
Set Cs = Application.ActiveSheet
''''' Delete invalid named ranges
For Each RangeName In ActiveWorkbook.Names
If InStr(1, RangeName.RefersTo, "#REF!") > 0 Then
RangeName.Delete
End If
Next RangeName
For Each RangeName In ActiveWorkbook.Names
If InStr(1, RangeName, "Wk1", 1) > 0 Then
Set HighlightRange = RangeName.RefersToRange
NewRangeName = Replace(RangeName.Name, "Wk1", "cs.Name")
RangeName2 = Replace(RangeName, "='Wk1'", "'cs.Name'")
On Error Resume Next
HighlightRange.Copy Destination:=Worksheets("cs.Name").Range(RangeName2)
Range(RangeName2).Name = NewRangeName
On Error GoTo 0
End If
Next RangeName
MsgBox "Done"
End Sub
Took me some time to figure out whats not working when there is no error, but finally I think I managed to figure out the issue.
Replace the following line in your code
HighlightRange.Copy Destination:=Worksheets("cs.Name").Range(RangeName2)
to:
HighlightRange.Copy Destination:=Worksheets(cs.Name).Range(HighlightRange.Address)
This should give you desired result.
Syntax for Copy to destination is Destination:=Worksheets("sheet_name").Range(range). Here sheet_name should be the name of the sheet. So when you write Worksheets("cs.Name") code looks for the sheet named cs.Name which actually does not exist hence just use Worksheets(cs.Name). Second thing here is range (just to explain things better I am using $A$1:$A$5 as range). When you write .Range(RangeName2) code is looking for 'cs.Name'!$A$1:$A$5. Again this is incorrect because range should be written as .Range($A$1:$A$5). So .Range(HighlightRange.Address) will give you the proper range.
You can also play out in the line RangeName2 = Replace(RangeName, "='Wk1'", "'cs.Name'") to get proper address.
Hope this helps.
EDIT :
__________________________________________________________________________________
example of what i want. copy the named range Wk1Totalhrs from Wk1 sheet to Wk2-Wk7 sheets so that Wk1Totalhrs becomes Wk2Totalhrs,Wk3Totalhrs etc on the corresponding new sheet
Try the following code to achieve what you mentioned as your requirement in comment (or as above).
Sub ChangeNamedRangesOnNewWKsheet()
Dim RangeName As Name
Dim HighlightRange As Range
Dim RangeName2 As String, NewRangeName As String, SearchRange As String
Dim MyWrkSht As Worksheet, cs As Worksheet
Set MyWrkSht = ActiveWorkbook.Worksheets("Wk1")
SearchRange = "Wk1Totalhrs" '---> enter name of the range to be copied
''''' Delete invalid named ranges
For Each RangeName In MyWrkSht.Names
If InStr(1, RangeName.RefersTo, "#REF!") > 0 Then
RangeName.Delete
End If
Next RangeName
'For Each RangeName In MyWrkSht.Names ActiveWorkbook.Names
For Each RangeName In ActiveWorkbook.Names
If RangeName.Name = SearchRange Then '---> search for the named range Wk1Totalhrs
Set HighlightRange = RangeName.RefersToRange
For Each cs In ActiveWorkbook.Sheets
Debug.Print cs.Name
If cs.Name <> "Wk1" Then '---> don't do anything in the sheet Wk1
NewRangeName = Replace(RangeName.Name, "Wk1", cs.Name)
RangeName2 = Replace(RangeName, "='Wk1'", cs.Name)
HighlightRange.Copy Destination:=Worksheets(cs.Name).Range(HighlightRange.Address)
Range(RangeName2).Name = NewRangeName
End If
Next cs
End If
Next RangeName
End Sub
I think it's just as simple as this.
Public Sub ShowNames()
Dim Nm As Name
Dim i As Long
For Each Nm In ActiveWorkbook.Names
i = i + 1
Range("A1").Offset(i, 0).Value = Nm
Next Nm
End Sub
Im not getting error messages but the code is still not working.the named ranges are not copying from the Wk1 sheet to the Active sheet.
The following line will return false positives when the named range starts with or contains WK10, WK11, etc.
If InStr(1, RangeName, "Wk1", 1) > 0 Then
A little further down, you are quoting a variable property; this makes it a literal string, not the value of the variable property.
NewRangeName = Replace(RangeName.Name, "Wk1", "cs.Name")
You need a more concrete way to identify the defined names on WK1. After looking closely at your problem, I believe that you may have one or more dynamic named ranges that are defined by formulas. This would explain some of the 'not working' behavior of your code that should be working with more conventional ReferTo: properties.
There is also the problem of whether you should rewrite the RefersTo: of an existing defined named range or add a new named range. One common practise is to simply attempt to delete the named range un On Error Resume Next and then create a new one. I've never liked this method for a variety of reasons; one being that deleting a named range will make dependent named ranges refer to #REF! and I've never considered on error resume next to be a 'best practise'.
The following builds a dictionary of keys containing named ranges to be created and ones that already exist using multiple criteria. I've tested this repeatedly on a combination of conventional and dynamic named ranges with success.
Option Explicit
Sub ChangeNamedRangesOnNewWKsheet()
Dim nm As Name
Dim rtr As String, nm2 As String
Dim w As Long
Dim k As Variant, dict As Object
Set dict = CreateObject("Scripting.Dictionary")
dict.comparemode = vbTextCompare
With ActiveWorkbook
'Delete invalid named ranges and build dictionary of valid ones from WK1
For Each nm In .Names
If CBool(InStr(1, nm.RefersTo, "#REF!", vbTextCompare)) Or _
CBool(InStr(1, nm.RefersTo, "#NAME?", vbTextCompare)) Then
'Debug.Print nm.Name
On Error Resume Next
nm.Delete
Err.Clear
On Error GoTo 0
ElseIf LCase(Left(nm.Name, 3)) = "wk1" And _
(CBool(InStr(1, nm.RefersTo, "wk1!", vbTextCompare)) Or _
CBool(InStr(1, nm.RefersTo, "'wk1'!", vbTextCompare))) Then
dict.Item(Mid(nm.Name, 4)) = LCase(nm.RefersTo)
ElseIf LCase(Left(nm.Name, 2)) = "wk" Then
dict.Item(nm.Name) = LCase(nm.RefersTo)
End If
Next nm
For w = 1 To Worksheets.Count
With Worksheets(w)
If LCase(.Name) <> "wk1" And Left(LCase(.Name), 2) = "wk" Then
For Each k In dict
If dict.exists(.Name & k) Then
.Parent.Names(.Name & k).RefersTo = _
Replace(LCase(dict.Item(k)), "wk1", .Name, 1, -1, vbTextCompare)
ElseIf Left(LCase(k), 2) <> "wk" Then
.Parent.Names.Add _
Name:=.Name & k, _
RefersTo:=Replace(LCase(dict.Item(k)), "wk1", .Name, 1, -1, vbTextCompare)
End If
Next k
End If
End With
Next w
End With
dict.RemoveAll: Set dict = Nothing
'MsgBox "All worksheets done"
End Sub
Note that this creates/redefines all named ranges on all worksheets (other than WK1). As far as I can determine, the only chance to have false positives would be to have an existing named range with a name something like WK1wkrange (but that would just be silly).
This code works
Public Sub CopyNamedRanges()
Dim namedRange As Name
Dim targetRefersTo As String
Dim targetName As String
On Error Resume Next
For Each namedRange In ActiveWorkbook.Names
If Left$(namedRange.RefersTo, 6) = "='Wk1'" And Left$(namedRange.Name, 3) = "Wk1" Then
targetName = Replace(namedRange.Name, "Wk1", ActiveSheet.Name)
targetRefersTo = Replace(namedRange.RefersTo, "Wk1", ActiveSheet.Name)
ActiveWorkbook.Names.Add targetName, targetRefersTo ' Might error if it already exists
ActiveWorkbook.Names(targetName).RefersTo = targetRefersTo
namedRange.RefersToRange.Copy Range(targetName) ' Remove this line if it's not required
End If
Next
End Sub
How the code works
This part If Left$(namedRange.RefersTo, 6) = "='Wk1'"
makes sure that the range refers to some cells on the sheet called Wk1
The other condition (Left$(namedRange.Name, 3) = "Wk1") would also match named ranges on sheets Wk10 - Wk19.
This part ActiveWorkbook.Names.Add targetName, targetRefersTo will adds a new named range that refers to the cells on the current sheet
This part namedRange.RefersToRange.Copy Range(targetName) copies the contents of the named range on the Wk1 sheet to the current sheet (remove the line if you don't need it)
Dim RangeName As Variant Try changing the variable type

Unable to update the value in combobox to sheet

I am new to VBA Coding.I have an userform which retrieves the value from excel sheet.There is a combobox which retrieves the value.But i want to change the combobox value & save it in excel.....
Image for Data in Excel
Dim temp As String
Dim findid As String
Dim lkrange As Range
Set lkrange = Sheet6.Range("A:D")
findid = TextBox1.Value
On Error Resume Next
temp = Application.WorksheetFunction.Vlookup(findid, lkrange, 1, 0)
If Err.Number <> 0 Then
MsgBox "ID not found"
Else
MsgBox "ID found"
Label5.Caption = Application.WorksheetFunction.Vlookup(findid, lkrange, 2, 0)
Label6.Caption = Application.WorksheetFunction.Vlookup(findid, lkrange, 3, 0)
ComboBox1.Value = Application.WorksheetFunction.Vlookup(findid, lkrange, 4, 0)
End If
End Sub
Private Sub CommandButton2_Click()
Dim fid As String
Dim rowc As Integer
Dim rowv As Integer
fid = TextBox1.Value
rowc = Application.WorksheetFunction.Match(fid, Range("A:A"), 0)
rowv = rowc - 1
Cells(rowv, 4).Values = marktable.ComboBox1.Value
End Sub
you could try the following
Option Explicit
Private Sub CommandButton1_Click()
Dim lkrange As Range
Dim rng As Range
Set lkrange = ThisWorkbook.Sheets("Sheet6").Range("A:A")
With Me
Set rng = MyMatch(.TextBox1.Value, lkrange)
If rng Is Nothing Then
MsgBox "ID not found"
Else
MsgBox "ID found"
.Label5.Caption = rng.Offset(0, 1)
.Label6.Caption = rng.Offset(0, 2)
.ComboBox1.Text = rng.Offset(0, 3)
End If
End With
End Sub
Private Sub CommandButton2_Click()
Dim lkrange As Range
Dim rng As Range
Set lkrange = ThisWorkbook.Sheets("Sheet6").Range("A:A")
With Me
Set rng = MyMatch(.TextBox1.Value, lkrange)
If Not rng Is Nothing Then rng.Offset(0, 3).Value = .ComboBox1.Text
End With
End Sub
Private Function MyMatch(val As Variant, rng As Range, Optional matchType As Variant) As Range
Dim row As Long
If IsMissing(matchType) Then matchType = 0
On Error Resume Next
row = Application.WorksheetFunction.Match(val, rng, matchType)
If Err = 0 Then Set MyMatch = rng.Parent.Cells(rng.Rows(row).row, rng.Column)
End Function
there were some errors:
Sheet6.Range("A:D") is not vaild
if you want to point to a sheet named "Sheet6" belonging to the Workbook where the macro resides, then you have to use ThisWorkbook.Sheets("Sheet6").Range("A:A")
Cells(...,...).Values =... is not valid
you must use Cells(...,...).Value =
but I think the following suggestions are more important:
Always use Option Explicit statement at the very beginning of every module
this will force you to explicitly declare each and every variable, but then it'll save you lots of time in debugging process
avoid/limit the use of On Error Resume Next statement
and, when used, make sure to have it followed as soon as possible by the "On Error GoTo 0" one. that way you have constant control on whether an error occurs and where
I confined it in a "wrapper" function (MyMatch()) only.
Always specify "full" references when pointing to a range
I mean, Cells(..,..) implictly points to the active sheet cells, which may not always be the one you'd want to point to.

Script for fixing broken hyperlinks in Excel

I have a spreadsheet that is used for tracking work orders. The first column of the sheet has numbers starting at 14-0001 and continue sequentially all the way down. The numbers were hyperlinked to the .XLS of their respective work order (ex. the cell containing 14-0001 links to Z:\WorkOrders\14-0001-Task Name\14-0001-Task Name.xls)
Problem is, My computer crashed and when Excel recovered the file all the hyperlinks changed from:
**"Z:\blah blah\WorkOrders\14-****-Task Name\14-****-Task Name.xls"**
to
**"C:\Users\blahblah\WorkOrders\14-****-Task Name\14-****-Task Name.xls"**
There are hundreds of entries so I was hoping that I could run a script to fix all of the hyperlinks.
Heres a script I found online which from what I understood is supposed to do what I want, but when I run the script from the VB window in Excel I get "Compile error: Argument not optional" and it highlights Sub CandCHyperlinx()
Code:
Option Explicit
Sub CandCHyperlinx()
Dim cel As Range
Dim rng As Range
Dim adr As String
Dim delstring As String
'string to delete: CHANGE ME! (KEEP quotes!)
delstring = "C:\Users\***\AppData\Roaming\Microsoft\Excel\"
'get all cells as range
Set rng = ActiveSheet.UsedRange
'ignore non hyperlinked cells
On Error Resume Next
'check every cell
For Each cel In rng
'skip blank cells
If cel <> "" Then
'attempt to get hyperlink address
adr = cel.Hyperlinks(1).Address
'not blank? then correct it, is blank get next
If adr <> "" Then
'delete string from address
adr = Application.WorksheetFunction.Substitute(adr, delstring)
'put new address
cel.Hyperlinks(1).Address = adr
'reset for next pass
adr = ""
End If
End If
Next cel
End Sub
Is this even the right script? What am I doing wrong?
Try this:
Sub Macro1()
Const FIND_TXT As String = "C:\" 'etc
Const NEW_TXT As String = "Z:\" 'etc
Dim rng As Range, hl As Hyperlink
For Each rng In ActiveSheet.UsedRange.Cells
If rng.Hyperlinks.Count > 0 Then
Set hl = rng.Hyperlinks(1)
Debug.Print rng.Address(), "Before", hl.TextToDisplay, hl.Address
hl.TextToDisplay = Replace(hl.TextToDisplay, FIND_TXT, NEW_TXT)
hl.Address = Replace(hl.Address, FIND_TXT, NEW_TXT)
Debug.Print rng.Address(), "After", hl.TextToDisplay, hl.Address
End If
Next rng
End Sub
I've just had the same problem, and all the macros I tried didn't work for me. This one is adapted from Tim's above and from this thread Office Techcentre thread. In my case, all my hyperlinks were in column B, between rows 3 and 400 and 'hidden' behind the filename, and I wanted to put the links back to my Dropbox folder where they belong.
Sub FixLinks3()
Dim intStart As Integer
Dim intEnd As Integer
Dim strCol As String
Dim hLink As Hyperlink
intStart = 2
intEnd = 400
strCol = "B"
For i = intStart To intEnd
For Each hLink In ActiveSheet.Hyperlinks
hLink.TextToDisplay = Replace (hLink.TextToDisplay, "AppData/Roaming/Microsoft/Excel",
"Dropbox/References")
hLink.Address = Replace(hLink.Address, "AppData/Roaming/Microsoft/Excel",
"Dropbox/References")
Next hLink
Next i
End Sub
Thanks for your help, Tim!