VBA Code to Create Named Ranges for Entire Columns in a Worksheet Based on a List of Names in Another Worksheet

[makaotk]

Hi Everyone. Thanks for taking the time to help me. I'm an intermediate Excel user and this is my first post. I always consult this site whenever I get stuck. However, I'm having difficulty figuring out the following:

BACKGROUND:
With my work, I often need from time to time to extract data from a very old/legacy custom-made software that contains several databases for the different divisions/sections of the organization (think 90's software, that has no integration other than exporting the data in Excel 97 format). I usually have a simple macro to clean up the resulting data (containing hundreds of columns and thousands of rows) and save it in the current Word format. Lately, the powers that be gave me notice that they will be tasking me with delivering ad-hoc excel reports, as well as creating forms/dashboards using various extracted databases' data. I've also been told that I will need to extract this data on a daily basis (end of day). Therefore, I will be needed to copy & paste the new daily data into the main Excel worksheet to get the most updated information. (I know what you're thinking... JUST UPGRADE TO 2023 TECH! You have no idea how the most simple common sense ideas are often the hardest to get accomplish!! Alas, this is the reality I live with right now).

GOAL:
I want to create Named Ranges using a macro/VBA code that will name each column (i.e., A:A, B:B, C:C --> 156 columns) in Worksheet#1 using the list of pre-determined names in Worksheet#2 (starting with A1, then A2, A3, etc). I want to run the macro every time I extract data from the database so I can just copy and paste the information in the main excel document, as well as have my formulas reference the named ranges. Is this possible? Thank you!

Jack

 

[offthelip]

try this on a copy of your workbook:

Sub test()
With Worksheets("Sheet2")
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
listnms = .Range(.Cells(1, 1), .Cells(lastrow, 1))
End With

For i = 1 To lastrow
 Set Rng = Range(Columns(i), Columns(i))
 ActiveWorkbook.Names.Add Name:=listnms(i, 1), RefersTo:=Rng
Next i
End Sub

 

[makaotk]

Wow, worked like a charm!! Thank you soooo much. This will save me hours!

 

[Norie]

If you are able to insert a row, temporarily, above the data you could try this.

Option Explicit

Sub CreateNameRanges()
Dim wsData As Worksheet
Dim wsHeadings As Worksheet
Dim rngData As Range
Dim rngHeadings As Range

    Set wsData = Sheets("Sheet1")
   
    Set wsHeadings = Sheets("Sheet2")
   
    Set rngHeadings = wsHeadings.Range("A1").CurrentRegion
   
    wsData.Rows(1).Insert
   
    rngHeadings.Copy
   
    wsData.Range("A1").PasteSpecial xlPasteValues, Transpose:=True
   
    wsData.Range("A1").CurrentRegion.CreateNames Top:=True, Left:=False, Bottom:=False, Right:=False
   
    wsData.Rows(1).Delete
   
End Sub