Add Named Ranges To Multiple Workbooks Using VBA

Good morning Happy Campers,

I have timesheets in work, where i created basic formulas to display times & worked hours etc.
I also have named ranges on 4 of the sheet.

The sheets are named as the department (area 1, stock control etc.)
All the sheets are identical in terms of layout, only the names of staff and hours worked are different.

When i created them, i tried to be pro-active and created flippin loads, through to October this year lol.
Problem being i created a Summary sheet for each workbook, which in short takes all names from all areas and collates them on the last tab, puts Mon-Sun across the top, enters the hours into the relevant days, merges hours worked in different areas and also splits the hours worked over each day.

Everything is working flawlessy.

Except, the above evolution of the sheet was done after i mass created the timesheet, and as such i need to manually open each sheet, set the ranges and name them, add a summary sheet, add the macro, save and close.
So, my request is this:

Is it possible to create a macro on book1, that when i open however many other workbooks (the actual timesheets) the code woould set and name the ranges for me?
The time sheets are all named according to the week -> 'W.C - 08.04.2013', 'W.C - 15.04.2013' etc.

I would be incredibly greatful if its possible!
Stalker

I am not sure I followed everything about your setup correctly, but it sounds like you have a workbook for each month. If that is correct, you should create a "template" and use that for each new month as needed. Here is my thinking... set up one workbook exactly like you want, but do not hard code the dates (which seem to be the only thing in the structure of each sheet that varies from workbook to workbook), rather, designate a cell for the month and the cell next to it for the year, then calculate that month's date using formulas. Create all your sheets using these formulas, fill in the names for the various departments, create your summary sheet and add your macros... now save the workbook as a Template file (extension xlt). Now, when you need a new copy of the workbook, don't pick new, choose to open your Template instead (exactly how varies by version, so you will need to tell us your Excel version if you cannot figure it out for yourself)... everything you setup originally will be in place and all you will need to do is enter the month and year into the cell you designated.

Hi Rick,

Thanks for the feedback.
The workbooks i use are done weekly, with the week commencing date always being the monday, i have created almost the entire years worth of sheets so would like to avoid re doing them all.
I guess i would like a macro that will look at the active workbook and name the ranges i need.

For any new sheets created i am using a template method, and copy->pasting the sheet, changing the name and job done.

Politely bumped

Stalker, this isn't very specific to what you've asked, but I am mostly certain that this can do the trick. If you can get the way this works, it should be a straightforward thing to do. Check the macro. You can modify it to suit your need. If you think it will suit your purpose, you can download the file.

Code:

---

Option Explicit

Sub AddCusNames()
   
    'Adds all listed names from this workbook to other workbooks
    Dim nm As Name
    Dim lng As Long
    Dim lngList As Long
    Dim var As Variant
    var = ThisWorkbook.Sheets(1).ListBoxes("lstWorkBooks").List
    For lngList = LBound(var) To UBound(var)
        If ThisWorkbook.Sheets(1).ListBoxes("lstWorkBooks").Selected(lngList) Then
            With ThisWorkbook.Sheets(1)
                For lng = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
                    If .Cells(lng, 4).Value = "Worksheet" Then
                        Call Application.Workbooks(var(lngList)).Worksheets(.Cells(lng, 3).Value).Names.Add(.Cells(lng, 1).Value, .Cells(lng, 2).Value)
                    Else
                        Call Application.Workbooks(var(lngList)).Names.Add(.Cells(lng, 1).Value, .Cells(lng, 2).Value)
                    End If
                Next lng
            End With
        End If
    Next lngList
   
End Sub

Sub GetWbks()

    'Get a list of ALL open workbooks
    Dim wbk As Workbook
    With ThisWorkbook.Sheets(1).ListBoxes("lstWorkBooks")
        .RemoveAllItems
        For Each wbk In Application.Workbooks
            If (wbk.Name <> ThisWorkbook.Name) And (Not wbk.IsAddin) And (wbk.Path <> Application.StartupPath) Then
                .AddItem wbk.Name
            End If
        Next wbk
    End With
   
End Sub
   
Sub GetNms()

    'Get the names of all named ranges in any selected workbook
    Dim nm As Name
    Dim wbk As Workbook
    Dim var As Variant
    Dim lng As Long
   
    On Error GoTo eRRh
    Set wbk = Workbooks.Open(Application.GetOpenFilename("*.xl*", , "Select File", , False), False, True)
    ReDim var(1 To ThisWorkbook.Names.Count, 1 To 4)
    For Each nm In ThisWorkbook.Names
        lng = lng + 1
        If InStr(1, nm.Name, "!") Then
            var(lng, 1) = Split(nm.Name, "!")(1)
        Else
            var(lng, 1) = nm.Name
        End If
        var(lng, 2) = "'" & nm.RefersTo
        If nm.Parent.Name = ThisWorkbook.Name Then
            var(lng, 3) = nm.RefersToRange.Parent.Name
            var(lng, 4) = "Workbook"
        Else
            var(lng, 3) = nm.Parent.Name
            var(lng, 4) = "Worksheet"
        End If
    Next nm
    ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp)(2).Resize(UBound(var), 4).Value = var
    wbk.Close 0
    Exit Sub
eRRh:    MsgBox "Unexpected Error!", vbExclamation, ""
   
End Sub

---

You can even manually update the list of names in the sheet (be sure you are 100% accurate in filling at the four properties of the named range, including taking care of the apostrophes (') )

Good morning and thanks for the response.

May take a while to get my head round it though, i have experience with VBA but not at the length conatined above :D
But none the less i will give it a shot, thanks again