Need VBA Coding to Copy Named Ranges into another workbook.

[swhgraham]

Would be extremely grateful if someone could kindly help me. I have an excel 2007 workbook which has numerous named ranges which I want to have a macro which can easily transfer the values of those name ranges into another workbook containing the same named but empty ranges.

swhgraham

 

[Domenic]

Assuming that both workbooks are open, try...

[font=Verdana][color=darkblue]Option[/color] [color=darkblue]Explicit[/color]

[color=darkblue]Sub[/color] test()

    [color=darkblue]Dim[/color] WKB1 [color=darkblue]As[/color] Workbook
    [color=darkblue]Dim[/color] WKB2 [color=darkblue]As[/color] Workbook
    [color=darkblue]Dim[/color] NM [color=darkblue]As[/color] Name
    
    [color=darkblue]Set[/color] WKB1 = Workbooks("Book1.xlsm")  [color=green]'change the source workbook name accordingly[/color]
    [color=darkblue]Set[/color] WKB2 = Workbooks("Book2.xlsm")  [color=green]'change the destination workbook name accordingly[/color]
    
    [color=darkblue]For[/color] [color=darkblue]Each[/color] NM [color=darkblue]In[/color] WKB1.Names
        WKB2.Names.Add NM.Name, NM.RefersTo
    [color=darkblue]Next[/color] NM
    
    MsgBox "Completed...", vbInformation
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]
[/font]

 

[swhgraham]

Thanks! Will try that tomorrow as it late here in Holland.

If Workbook2 is already open what vba code can I include that would request user to browse and open Workbook1, run the code you provided, close Workbook1 and finally saveas Workbook2?

very grateful!!!
swhgraham

 

[swhgraham]

I have not been able to get your code to run although I think it is geared towards adding the new ranges in WBK2. My WBK2 actually already most of WKB1 named ranges defined already (they just contain no values). I have searched various threads and have come up with the following code, but is failing

- CAN SOMEONE PLEASE, PLEASE help and tell me what I am doing wrong?

[FONT=Arial Narrow]'---------------------------------------------------------------------------------------
' Module    : MigrationMacro
' Author      : Stephen Graham-King SITI-ITGF/PB (GBSGRB)
' Date          : 24-Jul-11
' Purpose   : To copy all user data from prior version of GF IT Projects Estimator & Tracker tool
'                     into new version automatically (uses named ranges)
'---------------------------------------------------------------------------------------[/FONT]
[FONT=Arial Narrow]Option Explicit
[B]Sub Copy_All_Defined_Names()
[/B][COLOR=green]' Add each defined name from the active workbook ("Old Version") to the target workbook ("New Version").[/COLOR][/FONT]
[FONT=Arial Narrow][COLOR=green]' "NameRange.value" refers to the cell references the defined name points to.
[/COLOR]   
        Dim wkbk1 As Workbook
        Dim wkbk2 As Workbook
        Dim ws As Worksheet
        Dim nms As Names
        Dim Fname As String
        Dim oldFname As String
        Dim newFname As String
        Dim NameRange As String
        Dim NameSheet As String
        Dim strMessage As String
        Dim nm As Name
        Dim posn As Integer
        Dim i As Integer
        Dim fn As WorksheetFunction
                            
[COLOR=green]'With this new version workbook open browse to select old version
[/COLOR]        strMessage = "Browse to your current Estimator & Tracking Tool and open file"[/FONT]
[FONT=Arial Narrow]                    Fname = Application.GetOpenFilename("Micosoft Excel Files (*.xlsm),*.xlsm,", , strMessage, , False)
                   'Fname = BrowseFolder(Caption:="Select A Folder")
                                   If Fname = vbNullString Then
                                                       Debug.Print "No Folder Selected"
                                   Else
                                                       Debug.Print "New Folder: " & Fname
                                   End If
    
[COLOR=green]'find the position of the last "\" character in filename
[/COLOR]                        posn = 0
                        For i = 1 To Len(Fname)
                                    If (Mid(Fname, i, 1) = "\") Then posn = i
                        Next i[/FONT]
[FONT=Arial Narrow][COLOR=green]            'get filename without path
[/COLOR]                        Fname = Right(Fname, Len(Fname) - posn)[/FONT]
[FONT=Arial Narrow]    [COLOR=green]        'get filename without extension
[/COLOR]                        posn = InStr(Fname, ".")
                                    If posn <> 0 Then
                                            Fname = Left(Fname, posn - 1)
                                    End If
            
    oldFname = Fname
    newFname = ThisWorkbook.Name
    Debug.Print "oldFname: " & oldFname
    Debug.Print "newFname: " & newFname
    [/FONT]
[FONT=Arial Narrow][COLOR=green] 'Open the old version workbook and set workbook versions (old version = wkbk1, new version = wkbk2)
[/COLOR]                Application.Workbooks.Open (Fname)
                Set fn = Application.WorksheetFunction
                Set wkbk1 = Application.Workbooks(oldFname & ".xlsm")
                Set wkbk2 = Workbooks(newFname)[/FONT]
[FONT=Arial Narrow]                                                        
                      For Each nm In wkbk2.Names    [/FONT][FONT=Arial Narrow]'Code fails here in red[/FONT]
[FONT=Arial Narrow]                            NameRange = Right(nm.RefersTo, Len(nm.RefersTo) - fn.Find("!", nm.RefersTo))
[/FONT][FONT=Arial Narrow][COLOR=red]                            wkbk2.Range(NameRange).Value = [/COLOR][COLOR=red]wkbk1.Range(NameRange).Value[/COLOR][/FONT]
[FONT=Arial Narrow]                      Next nm
   
End Sub[/FONT]