Excel 2010 VBA - Use Value of variable as another variable - vba

This is a practice I follow while writing VBA code.
I usually set worksheet names without spaces into variable names.
For example I have a workbook with 3 worksheets with following names
1 - Control
2 - 60 W Status
3 - 60 W Status Pvt Tbl
I usually set worksheets names as worksheet variables in the following way:
Set wb = thisworkbook
Set wsControl = wb.sheets("Control")
Set ws60WStatus = wb.sheets("60 W Status")
Set ws60WStatusPvtTbl = wb.sheets("60 W Status Pvt Tbl")
Now I want to make this dynamic meaning my code should loop through all the worksheets in a workbook and store the worksheet names without spaces into variable names like ws*
So I have the following code so far:
Sub GetwsNames()
Set wb = thisworkbook
Dim wsNames()
i = 0
'Loop through the workbook and store the names as wsName in an array
For each ws in worksheets
Redim Preserve wsNames(i)
Var1 = ws.Name
Var2 = Replace(ws.Name," ", "")
Var3 = "ws" & Var2
wsNames(i) = Var3
i = i + 1
Next
'Loop through array wsNames() and assign each element to corresponding workbook names
'For example
'Set wsControl = wb.sheets("Control")
'Set ws60WStatus = wb.Sheets("60 W Status")
'Set ws60WStatusPvtTbl = wb.sheets("60 W Status Pvt Tbl")
End Sub
I would like to know if there is any way to achieve this. Can we use value of a variable as another variable?

You can already reference sheets by name from the worksheets collection.
Worksheets("Sheet 1")
If you instead want to reference them by your modified names, creating an array or dictionary will work great. I suggest using a dictionary. It will allow you to reference items by key. In this example I use the modified name as the key and use the worksheet object as the item.
Dim myWorksheets As Scripting.Dictionary
Set myWorksheets = New Scripting.Dictionary
Dim ws As worksheet
For Each ws In ThisWorkbook.Worksheets
Dim modifiedName As String
modifiedName = "ws" & Replace(ws.Name, " ", "")
myWorksheets.Add modifiedName, ws
Next
'You can now reference the worksheets by the modified names, through the dictionary
myWorksheets("wsControl").Cells(1, 1) = "Hi"
myWorksheets("ws60WStatus").Cells(1, 1) = "there"
myWorksheets("ws60WStatusPvtTbl").Cells(1, 1) = "world."
Note that you will need to add a reference to MS Scripting runtime in order to use dictionaries.
To add the reference, go to Tools->References and check its box.

Related

VBA : Run a macro FOR another workbook (not from)

I have a workbook (A) in which I have one module with one subroutine. The subroutine downloads an excel file (workbook(B)) from the internet and opens it. The problem I'm faced with is finding a way to execute a subroutine in workbook (B) from the sub in workbook (A).
To reiterate, I have my desired subroutine only in workbook (A) and wish to apply it to workbook (B) by use of the sub in workbook (A).
Note: In my code workbook (B) = Nuance Mobility JIRA.xls and the desired subroutine in workbook (B) that needs to be executed is removeColumns().
My code can be found below :
Public Sub DL()
Dim WebUrl As String
Dim x As Workbook
Dim z As Workbook
Dim nmjexcel As String
Dim xlApp As Excel.Application
' I check to see if the file exists and delete it if it does
nmjexcel = "C:\Users\" & [A2] & "\Downloads\Nuance Mobility JIRA.xls"
If Len(Dir(nmjexcel)) <> 0 Then
SetAttr nmjexcel, vbNormal
Kill nmjexcel
End If
'I open chrome and download the file from an URL
WebUrl = [J1]
Shell ("C:\Program Files (x86)\Google\Chrome\Application\chrome.exe -url " & WebUrl)
Application.Wait (Now + TimeValue("0:00:3"))
'I create a new 'hidden' excel app and open workbook (B)
Set xlApp = New Excel.Application
xlApp.Visible = False
Set x = Workbooks.Open("C:\Users\" & [A2] & "\Downloads\Nuance Mobility JIRA.xls")
' I delete some rows, a picture and some columns.
' It's here that i would like my other subroutine, removeColumns(), to take place !
With x.Sheets("general_report")
.Rows("1:3").Delete
.Shapes.Range(Array("Picture 1")).Delete
.Cells.UnMerge
.Range("A:A,D:D,E:E,F:F,H:H,I:I,J:J,K:K,L:L,M:M,N:N,O:O,P:P").Delete Shift:=xlToLeft
End With
'Then I copy whats left and paste it into workbook (A)
Set z = ThisWorkbook
Application.ScreenUpdating = False
x.Sheets("general_report").Range("A1").CurrentRegion.Copy
z.Sheets(1).Range("A13").PasteSpecial xlValues
x.Save
x.Application.CutCopyMode = False
x.Close
End Sub
My desired sub to be executed is the following
Sub removeColumns()
Dim rng As Range 'store the range you want to delete
Dim c 'total count of columns
Dim I 'an index
Dim j 'another index
Dim headName As String 'The text on the header
Dim Status As String 'This vars is just to get the code cleaner
Dim Name As String
Dim Age As String
Dim sht As Worksheet
Rows("1:3").Delete
Key = "Key"
Summary = "Summary"
Status = "Status"
Set sht = Sheets("general_report")
sht.Activate 'all the work in the sheet "Incidents"
c = Range("A1").End(xlToRight).Column
'From A1 to the left at the end, and then store the number
'of the column, that is, the last column
j = 0 'initialize the var
For I = 1 To c 'all the numbers (heres is the columns) from 1 to c
headName = Cells(1, I).Value
If (headName <> Key) And (headName <> Summary) And (headName <> Status) Then
'if the header of the column is differente of any of the options
j = j + 1 ' ini the counter
If j = 1 Then 'if is the first then
Set rng = Columns(I)
Else
Set rng = Union(rng, Columns(I))
End If
End If
Next I
rng.Delete 'then brutally erased from leaf
End Sub
Thank you very much in advance !
Further questions :
1) Is there a way to keep the downloaded excel hidden ?
I have :
Set xlApp = New Excel.Application
xlApp.Visible = False
Set x = Workbooks.Open("C:\Users\" & [A2] & "\Downloads\Nuance Mobility JIRA.xls")
But if i use x= xlApp.Workbooks.Open it gives me an error 'subscript out of range' and highlights :
Set sht = Sheets("general_report")
I tried doing
Dim xlApp as Excel.Application)
...
Set sht = xlApp.Sheets("general_report")
But it gets more errors
2) More generally, is their a way to keep the focus on my workbook (A), so that when chrome downloads the workbook (B) the chrome window doesn't pop up in front ?
The problem you are facing, occurs because you dont directly address the needed worksheet/workbook, you rather always use the Selected worksheet, which you shouldn´t. It´s unclear and can be done just as simple if directly referring.
To refer to the worbookB I added a parameter to the sub removeColumns, so you can pass the needed workbook.
In the sub then, you just need to use the reference wherever you are working with the worksheet.
So instead of just writing:
somVariable = Cells(1,1).Value 'This always refers to the 'Selected' worksheet
You have to write:
someVariable = myWorkbook.myWorksheet.Cells(1,1).Value
'or to use the parameter wb like i did in your code:
someVariable = wb.Sheets(1).Cells(1,1).Value
'Here the first sheet of this workbook will be used
'You also can use the 'With' statment here:
With wb.Sheets(1)
someVariable = .Cells(1,1).Value 'Note the dot in font of the 'Cells'
End With
So to use this knowledge in you example, you should try to alter code like following:
/////////////////////////////////////////////////////////////////////////
Set xlApp = New Excel.Application
xlApp.Visible = False
xlApp.Workbooks.Open("C:\Users\" & [A2] & "\Downloads\Nuance Mobility JIRA.xls")
Set x = xlApp.Workbooks(1)
Call removeColumns(x)
/////////////////////////////////////////////////////////////////////////
Sub removeColumns(ByVal wb As Workbok)
...
'Always when you are referring to the workbook, you have to use the reference passed as parameter
wb.Sheets("general_report").Rows("1:3").Delete
'In you code the first three rows will always be deleted from the 'Selected' sheet and not the one you are working on later, the 'general_report'
...
Set sht = wb.Sheets("general_report")
'Also don´t activate() sheet here, youst directly refer to it later
'sht.Activate 'all the work in the sheet "Incidents"
'You can directly refer t it over the variable you created, like this:
c = sht.Range("A1").End(xlToRight).Column
'From A1 to the left at the end, and then store the number
'of the column, that is, the last column
j = 0 'initialize the var
For I = 1 To c 'all the numbers (heres is the columns) from 1 to c
headName = sht.Cells(1, I).Value
If (headName <> Key) And (headName <> Summary) And (headName <> Status) Then
'if the header of the column is differente of any of the options
j = j + 1 ' ini the counter
If j = 1 Then 'if is the first then
Set rng = sht.Columns(I)
Else
Set rng = Union(rng, sht.Columns(I))
End If
End If
Next I
rng.Delete 'then brutally erased from leaf
End Sub
Hope I could help and if something is still unclear feel free to ask.

Excel VBA - Subscript out of range - Sheets name as a variable

I am trying to work on a Worksheet whose name is a variable.
I have a main sheet, called "data" where I go to catch a list of names of existing sheets.
My code is as follows :
Dim data as Worksheet
dim sheet_name as String
Dim i as Integer
Set data = ThisWorkbook.Sheets("Data")
For i = 2 to 10
sheet_name = data.Range("A"&i).Value
With ThisWorkbook.Sheets(sheet_name)
'Operations on the worksheet
End With
Next i
The error prompted is "Runtime Error 9 : Subscript Out of Range" for the specific line :
With This Workbook.Sheets(sheet_name)
It is as if the object Sheets didn't understand the string sheet_name.
The Sheet "sheet_name" exists for sure, I double-checked.
Unfortunately, I cannot call the sheet by its name because I have too many sheets to operate on, this is why I wanted to do a loop.
I tried not working with the "With" clause but just referring to every object of the sheets with "ThisWorkbook.Sheets(sheet_name) in front but doesn't work either.
Do you know if it is possible to call a string variable inside a Sheets()?
Thanks a lot for your help !
Kind regards,
The reason for your error was given in the comments above by #chris neilsen
You could use the code below to check or avoid having these kind of errors:
Option Explicit
Sub CheckShtExists()
Dim data As Worksheet
Dim sheet_name As String
Set data = ThisWorkbook.Sheets("Data")
Dim ws As Worksheet
Dim ShtNamesArr() As String
Dim i As Long
ReDim ShtNamesArr(0 To ThisWorkbook.Worksheets.Count - 1) ' resize array to number of worksheets in This Workbook
' loop thourgh all worksheets and store their names in array
For Each ws In ThisWorkbook.Worksheets
ShtNamesArr(i) = ws.Name
i = i + 1
Next ws
For i = 2 To 10
If data.Range("A" & i).Value <> "" Then ' ignore blank cells
sheet_name = data.Range("A" & i).Value
If Not IsError(Application.Match(sheet_name, ShtNamesArr, 0)) Then ' use Application.Match to see there is a sheet with this name
With ThisWorkbook.Sheets(sheet_name)
'Operations on the worksheet
End With
Else ' No Match
MsgBox sheet_name & " doesn't exists in your workbook"
End If
End If
Next i
End Sub

vba: How can I change the name of a new added workbook in an inactive worksheet?

With Swkbook.Worksheets("SalesRecords")
For intIndex = 1 To .Range("D1", .Range("D1048576").End(xlUp)).Rows.Count - 1
strNewName = .Range("d2").Offset(intIndex - 1, 0).Value
Namesexist = False
For Each wksheet In Nwkbook.Worksheets
If VBA.LCase(strNewName) = VBA.LCase(wksheet.Name) Then
Namesexist = True
End If
Next wksheet
If namesexits = False Then
Set WS = Nwkbook.Worksheets.Add
Worksheets(WS).Name = strNewName
End If
Next intIndex
End With
I am working on a active workbook called "abc" and there are two another workbook called "S" and "N".
Now I want to let the D rows value in S to be the name of each new worksheet in N (without repeat)
The above are my code, however, this statement get error:
Worksheets(WS).Name = strNewName
Type mismatch.
May you help me to solve the problem? Thanks you.
I have declared the variable before the with statement:
Dim intIndex As Integer
Dim strNewName As String
Dim Namesexist As Boolean
but I now get another error:
which is from:
WS.Name = strNewName
After this line gets executed
Set WS = Nwkbook.Worksheets.Add
WS is a Worksheet object that contains a reference to that new worksheet you just added. You can then change its name like this:
WS.Name = strNewName
In fact, I advise you to declare your variables properly using Dim
Dim WS As Worksheet
This is a good idea for million different reasons, one of which is that you can then use autocomplete to easily see what you can do with your object:

Assigning String a value from another workbook

I am trying to assign a value from a cell in another workbook to a string variable in my code.
So currently my code will look up column P,G,H,I in the workbook but I have created another workbook which I have input all the columns I need it to look up. So on the other workbook I have mapped it out so the Ship to site ID value is P but I cant workout how to assign the value from this workbook to the below code.
I want it so I can just change the value in my mapping workbook rather than having to come back to my coding and change the column letter everytime there is a change.
ShipToSiteID = Application.WorksheetFunction.Trim(Range("P" & counter))
AltShipTo1 = Application.WorksheetFunction.Trim(Range("G" & counter))
AltShipTo2 = Application.WorksheetFunction.Trim(Range("H" & counter))
AltShipToCity = Application.WorksheetFunction.Trim(Range("I" & counter))
When you use Range("P" & counter) this will be refering to the ActiveWorksheet
so it is the same as ActiveWorksheet.Range("P" & counter)
If you want to refer to another workbook then you need use a range from a sheet within this workbook.
Sub test()
Dim newWorkbook As Workbook
Dim newWorksheet As Worksheet
'NewWorkbook.xlsm is already open
Set newWorkbook = Workbooks("NewWorkbook.xlsm")
Set newWorksheet = newWorkBook.Worksheets("Sheet1")
MsgBox "This value is A1 in NewWorkbook - " & newWorksheet.Range("A1").Value
End Sub
You can also get an open workbook by index (although this isn't really recommended).
Set newWorkbook = Workbooks(1)
You can get and open a workbook at the same time by using Workbook.Open
Set newWorkbook = Workbooks.Open("C:/Path/To/Workbook")
Or get and add a new workbook by using Workbook.Add
Set newWorkbook = Workbooks.Add()
Also, regarding your usage of Application.WorksheetFunction.Trim
There is a built in VBA Trim() function that would suit better..
I'm not entirely sure from your question how you are trying to copy from one workbook to another, but the below code is a general approach for getting a specific cell's data out of another workbook.
Sub GetOtherValues()
Dim thisWS As Worksheet
Dim thatWS As Worksheet
Dim thatWB As Workbook
Dim ShipToSiteID As String
Dim counter As Integer
Set thisWS = ActiveSheet
Set thatWB = Workbooks.Open("C:\demo.xlsx")
Set thatWS = thatWB.Worksheets(1)
counter = 2 'initialized here for the sake of code completeness
ShipToSiteID = Trim(thatWS.Range("P" & counter))
'Do something else with the trimmed data from ShipToSiteID
thisWS.Cells(2, 2) = ShipToSiteID
thatWB.Close
End Sub
This code assumes you are running from the current workbook, and there is another worksheet/workbook that you need to get the data from. After declaring the variables, it assigns thisWB to be the current worksheet, then opens the next workbook and assigns the first worksheet to thatWS. We can now use thatWS and the counter variable to copy and trim the data, and stick it in the variable ShipToSiteID (and then do whatever else you're needing to do with it).

How to change Named Range Scope

When I create a named range through the Name Manager, I'm given the option of specifying Workbook or [worksheet name] scope. But if then want to change scope, the drop-down is grayed out. Is there a way, in either Name Manager or, preferablly, VBA to change the scope of an existing named range?
For example:
testName refers to 'sheet1'!A1:B2 with scope Workbook. How would I change that to
testName refers to 'sheet1'!A1:B2 with 'sheet1' scope?
I found the solution! Just copy the sheet with your named variables. Then delete the original sheet. The copied sheet will now have the same named variables, but with a local scope (scope= the copied sheet).
However, I don't know how to change from local variables to global..
You can download the free Name Manager addin developed by myself and Jan Karel Pieterse from
http://www.decisionmodels.com/downloads.htm
This enables many name operations that the Excel 2007 Name manager cannot handle, including changing scope of names.
In VBA:
Sub TestName()
Application.Calculation = xlManual
Names("TestName").Delete
Range("Sheet1!$A$1:$B$2").Name = "Sheet1!TestName"
Application.Calculation = xlAutomatic
End Sub
Check out these two subs that reverse each other and flip the scope (worksheet to workbook or reverse) of all named ranges that refer to a range on the active sheet.
Option Explicit
'---------------------------------------------------------------------------------------
' Procedure : RescopeNamedRangesToWorkbook
' Author : JS20'07'11
' Date : 11/18/2013
' Purpose : Rescopes the parent of worksheet scoped named ranges to the active workbook
' for each named range with a scope equal to the active sheet in the active workbook.
'---------------------------------------------------------------------------------------
Public Sub RescopeNamedRangesToWorkbook()
Dim wb As Workbook
Dim ws As Worksheet
Dim objName As Name
Dim sWsName As String
Dim sWbName As String
Dim sRefersTo As String
Dim sObjName As String
Set wb = ActiveWorkbook
Set ws = ActiveSheet
sWsName = ws.Name
sWbName = wb.Name
'Loop through names in worksheet.
For Each objName In ws.Names
'Check name is visble.
If objName.Visible = True Then
'Check name refers to a range on the active sheet.
If InStr(1, objName.RefersTo, sWsName, vbTextCompare) Then
sRefersTo = objName.RefersTo
sObjName = objName.Name
'Check name is scoped to the worksheet.
If objName.Parent.Name <> sWbName Then
'Delete the current name scoped to worksheet replacing with workbook scoped name.
sObjName = Mid(sObjName, InStr(1, sObjName, "!") + 1, Len(sObjName))
objName.Delete
wb.Names.Add Name:=sObjName, RefersTo:=sRefersTo
End If
End If
End If
Next objName
End Sub
'---------------------------------------------------------------------------------------
' Procedure : RescopeNamedRangesToWorksheet
' Author : JS20'07'11
' Date : 11/18/2013
' Purpose : Rescopes each workbook scoped named range to the specific worksheet to
' which the range refers for each named range that refers to the active worksheet.
'---------------------------------------------------------------------------------------
Public Sub RescopeNamedRangesToWorksheet()
Dim wb As Workbook
Dim ws As Worksheet
Dim objName As Name
Dim sWsName As String
Dim sWbName As String
Dim sRefersTo As String
Dim sObjName As String
Set wb = ActiveWorkbook
Set ws = ActiveSheet
sWsName = ws.Name
sWbName = wb.Name
'Loop through names in worksheet.
For Each objName In wb.Names
'Check name is visble.
If objName.Visible = True Then
'Check name refers to a range on the active sheet.
If InStr(1, objName.RefersTo, sWsName, vbTextCompare) Then
sRefersTo = objName.RefersTo
sObjName = objName.Name
'Check name is scoped to the workbook.
If objName.Parent.Name = sWbName Then
'Delete the current name scoped to workbook replacing with worksheet scoped name.
objName.Delete
ws.Names.Add Name:=sObjName, RefersTo:=sRefersTo
End If
End If
End If
Next objName
End Sub
An alternative way is to "hack" the Excel file for 2007 or higher, although it is advisable to take care if you are doing this, and keep a backup of the original:
First save the Excel spreadsheet as an .xlsx or .xlsm file (not binary). rename the file to .zip, then unzip. Go to the xl folder in the zip structure and open workbook.xml in Wordpad or a similar text editor. Named ranges are found in the definedName tags. Local scoping is defined by localSheetId="x" (the sheet IDs can be found by pressing Alt-F11 in Excel, with the spreadsheet open, to get to the VBA window, and then looking at the Project pane). Hidden ranges are defined by hidden="1", so just delete the hidden="1" to unhide, for example.
Now rezip the folder structure, taking care to maintain the integrity of the folder structure, and rename back to .xlsx or .xlsm.
This is probably not the best solution if you need to change the scope of or hide/unhide a large number of defined ranges, though it works fine for making one or two small tweaks.
create the new name from scratch and delete the old one.
These answers were helpful in solving a similar issue while trying to define a named range with Workbook scope. The "ah-HA!" for me is to use the Names Collection which is relative to the whole Workbook! This may be restating the obvious to many, but it wasn't clearly stated in my research, so I share for other's with similar questions.
' Local / Worksheet only scope
Worksheets("Sheet2").Names.Add Name:="a_test_rng1", RefersTo:=Range("A1:A4")
' Global / Workbook scope
ThisWorkbook.Names.Add Name:="a_test_rng2", RefersTo:=Range("B1:b4")
If you look at your list of names when Sheet2 is active, both ranges are there, but switch to any other sheet, and "a_test_rng1" is not present.
Now I can happily generate a named range in my code with what ever scope I deem appropriate. No need mess around with the name manager or a plug in.
Aside, the name manager in Excel Mac 2011 is a mess, but I did discover that while there are no column labels to tell you what you're looking at while viewing your list of named ranges, if there is a sheet listed beside the name, that name is scoped to worksheet / local. See screenshot attached.
Full credit to this article for putting together the pieces.
here's how I promote all worksheet names to global names. YMMV
For Each wsh In ActiveWorkbook.Worksheets
For Each n In wsh.Names
' Get unqualified range name
Dim s As String
s = Split(n.Name, "!")(UBound(Split(n.Name, "!")))
' Add to "Workbook" scope
n.RefersToRange.Name = s
' Remove from "Worksheet" scope
Call n.Delete
Next n
Next wsh
This still needs more refining however works with all simple references, without killing existing local names.
Type GlobalNamesToLocalNames_Type
Name As String
Sheet As String
Ref As String
End Type
Sub GlobalNamesToLocalNames(Optional Void As Variant)
Dim List() As GlobalNamesToLocalNames_Type
Dim Count As Long
Dim Name As Name
Dim Dat() As String
Dim X As Long
' count the size
For Each Name In ActiveWorkbook.Names
Count = Count + 1
Next
ReDim List(Count - 1)
Count = 0
' Collecect all name data
For Each Name In ActiveWorkbook.Names
With List(Count)
' Pick up only the name
If InStr(Name.Name, "!") > 0 Then
Dat = Split(Name.Name, "!")
.Name = Dat(1)
Else
.Name = Name.Name
End If
' pick up the sheet and refer
Dat = Split(Name.RefersTo, "!")
.Sheet = Mid(Dat(0), 2)
.Ref = Dat(1)
' make local sheet name
.Name = .Sheet & "!" & .Name
End With
Count = Count + 1
Next
' Delete all names
For Each Name In ActiveWorkbook.Names
Name.Delete
Next
'rebuild all the names
For X = 0 To Count - 1
With List(X)
If Left(.Ref, 1) <> "#" Then
ActiveWorkbook.Names.Add Name:=.Name, RefersToLocal:="=" & .Sheet & "!" & .Ref
End If
End With
Next
End Sub
For me it works that when I create new Name tag for the same range from the Name Manager it gives me the option to change scope ;) workbook comes as default and can be changed to any of the available sheets.
The code of JS20'07'11 is really incredible simple and direct. One suggestion that I would like to give is to put a exclamation mark in the conditions:
InStr(1, objName.RefersTo, sWsName+"!", vbTextCompare)
Because this will prevent adding a NamedRange in an incorrect Sheet. Eg: If the NamedRange refers to a Sheet named Plan11 and you have another Sheet named Plan1 the code can do some mess when add the ranges if you don't use the exclamation mark.
UPDATE
A correction: It's best to use a regular expression evaluate the name of the Sheet. A simple function that you can use is the following (adapted by http://blog.malcolmp.com/2010/regular-expressions-excel-add-in, enable Microsoft VBScript Regular Expressions 5.5):
Function xMatch(pattern As String, searchText As String, Optional matchIndex As Integer = 1, Optional ignoreCase As Boolean = True) As String
On Error Resume Next
Dim RegEx As New RegExp
RegEx.Global = True
RegEx.MultiLine = True
RegEx.pattern = pattern
RegEx.ignoreCase = ignoreCase
Dim matches As MatchCollection
Set matches = RegEx.Execute(searchText)
Dim i As Integer
i = 1
For Each Match In matches
If i = matchIndex Then
xMatch = Match.Value
End If
i = i + 1
Next
End Function
So, You can use something like that:
xMatch("'?" +sWsName + "'?" + "!", objName.RefersTo, 1) <> ""
instead of
InStr(1, objName.RefersTo, sWsName+"!", vbTextCompare)
This will cover Plan1 and 'Plan1' (when the range refers to more than one cell) variations
TIP: Avoid Sheet names with single quotes ('), :) .
I added some additional lines of code to JS20'07'11's previous Makro to make sure that the name of the sheet's Named Ranges isn't already a name of the workbook's Named Ranges.
Without these lines the already definied workbook scooped Named range is deleted and replaced.
Public Sub RescopeNamedRangesToWorkbookV2()
Dim wb As Workbook
Dim ws As Worksheet
Dim objNameWs As Name
Dim objNameWb As Name
Dim sWsName As String
Dim sWbName As String
Dim sRefersTo As String
Dim sObjName As String
Set wb = ActiveWorkbook
Set ws = ActiveSheet
sWsName = ws.Name
sWbName = wb.Name
'Loop through names in worksheet.
For Each objNameWs In ws.Names
'Check name is visble.
If objNameWs.Visible = True Then
'Check name refers to a range on the active sheet.
If InStr(1, objNameWs.RefersTo, sWsName, vbTextCompare) Then
sRefersTo = objNameWs.RefersTo
sObjName = objNameWs.Name
'Check name is scoped to the worksheet.
If objNameWs.Parent.Name <> sWbName Then
'Delete the current name scoped to worksheet replacing with workbook scoped name.
sObjName = Mid(sObjName, InStr(1, sObjName, "!") + 1, Len(sObjName))
'Check to see if there already is a Named Range with the same Name with the full workbook scope.
For Each objNameWb In wb.Names
If sObjName = objNameWb.Name Then
MsgBox "There is already a Named range with ""Workbook scope"" named """ + sObjName + """. Change either Named Range names or delete one before running this Macro."
Exit Sub
End If
Next objNameWb
objNameWs.Delete
wb.Names.Add Name:=sObjName, RefersTo:=sRefersTo
End If
End If
End If
Next objNameWs
End Sub
Found this at theexceladdict.com
Select the Named range on your worksheet whose scope you want to change;
Open the Name Manager (Formulas tab) and select the name;
Click Delete and OK;
Click New… and type in the original name back in the Name field;
Make sure Scope is set to Workbook and click Close.