Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.
Option Explicit
Option Base 1
Sub MakeNames()
Dim arrUnique() 'create array of unique values in column A
Dim lngLastRow As Long 'find the row # of the last occupied cell in column A
Dim lngItem As Long 'represents items in the array
Dim lngRow As Long 'row # for loop
Dim lngLastCol As Long 'last occupied column in row 1
Dim lngFirst As Long '1st row # of the array item found in column A
Dim lngLast As Long 'last row # of the array item found in column A
lngLastRow = Range("A" & Rows.Count).End(xlUp).Row
For lngRow = 2 To lngLastRow
If Application.CountIf(Range("A2:A" & lngRow), Range("A" & lngRow)) = 1 Then
lngItem = lngItem + 1
ReDim Preserve arrUnique(lngItem)
arrUnique(lngItem) = Range("A" & lngRow).Value
End If
Next lngRow
lngLastCol = Range("IV1").End(xlToLeft).Column
For lngItem = LBound(arrUnique) To UBound(arrUnique)
lngFirst = Range("A:A").Find(arrUnique(lngItem), , , xlWhole, xlRows, xlNext).Row
lngLast = Range("A:A").Find(arrUnique(lngItem), , , xlWhole, xlRows, xlPrevious).Row
Names.Add "Range_" & arrUnique(lngItem), Range(Cells(lngFirst, 1), Cells(lngLast, lngLastCol))
Next lngItem
End Sub
Sub specialmacro()
Dim rng As Range
Dim rng2 As Range
Dim celle As Range
Dim coll As New Collection
Dim i As Long
Dim startcol As Long
Dim endcol As Long
Dim rngname As String
With Sheets("Sheet1")
Set rng = Range(.Cells(2, "D"), .Cells(2, "M"))
End With
For Each celle In rng
If celle <> celle.Offset(0, -1) Then
startcol = celle.Column
endcol = 0
rngname = "Range_" & celle
End If
If celle <> celle.Offset(0, 1) Then
endcol = celle.Column
End If
If startcol > 0 And endcol > 0 Then
With Sheets("Sheet1")
Set rng2 = .Range(.Cells(3, startcol), .Cells(7, endcol))
ActiveWorkbook.Names.Add Name:=rngname, RefersTo:="""Sheet1!""" & rng2.Address
End With
End If
Next celle
End Sub
named-ranges-03.xls
Sub specialmacro()
Dim rng As Range
Dim rng2 As Range
Dim celle As Range
Dim startcol As Long
Dim endcol As Long
Dim rngname As String
Dim IDcellcolm As Long
Dim IDcellrow As Long
Dim IDcellrng As Range
Dim namesrng As Range
Dim lastrow As Long
With Sheets("Sheet1")
.Activate
Set rng = .UsedRange
End With
For Each celle In rng
If celle = "ID#" Then
IDcellcolm = celle.Column
IDcellrow = celle.Row
lastrow = celle.End(xlDown).Row
End If
Next celle
Set namesrng = Range(Cells(IDcellrow, IDcellcolm + 1), Cells(IDcellrow, IDcellcolm + 1).End(xlToRight).Offset(0, -1))
For Each celle In namesrng
If celle <> celle.Offset(0, -1) Then
startcol = celle.Column
endcol = 0
rngname = "Range_" & celle
End If
If celle <> celle.Offset(0, 1) Then
endcol = celle.Column
End If
If startcol > 0 And endcol > 0 Then
With Sheets("Sheet1")
Set rng2 = .Range(.Cells(IDcellrow + 1, startcol), .Cells(lastrow, endcol))
ActiveWorkbook.Names.Add Name:=rngname, RefersTo:="Sheet1!" & rng2.Address
End With
End If
Next celle
End Sub
named-ranges-04.xls
Sub specialmacro()
Dim ws As Worksheet
Dim rng As Range
Dim rng2 As Range
Dim celle As Range
Dim startcol As Long
Dim endcol As Long
Dim rngname As String
Dim IDcellcolm As Long
Dim IDcellrow As Long
Dim IDcellrng As Range
Dim namesrng As Range
Dim lastrow As Long
Dim str1 As String
Dim refsto As String
str1 = "Range_"
Set ws = Sheets("Sheet1")
With Sheets("Sheet1")
.Activate
Set rng = .UsedRange
End With
For Each celle In rng
If celle = "ID#" Then
IDcellcolm = celle.Column
IDcellrow = celle.Row
lastrow = celle.End(xlDown).Row
End If
Next celle
Set namesrng = Range(Cells(IDcellrow, IDcellcolm + 1), Cells(IDcellrow, IDcellcolm + 1).End(xlToRight).Offset(0, -1))
For Each celle In namesrng
If celle <> celle.Offset(0, -1) Then
startcol = celle.Column
endcol = 0
rngname = str1 & celle
End If
If celle <> celle.Offset(0, 1) Then
endcol = celle.Column
End If
If startcol > 0 And endcol > 0 Then
With Sheets("Sheet1")
Set rng2 = .Range(.Cells(IDcellrow + 1, startcol), .Cells(lastrow, endcol))
refsto = "Sheet1!" & rng2.Address
MsgBox "Refers to " & refsto
ActiveWorkbook.Names.Add Name:=rngname, RefersTo:=refsto
End With
End If
Next celle
End Sub
named-ranges-06.xls
Sub specialmacro()
Dim ws As Worksheet
Dim rng As Range
Dim rng2 As Range
Dim celle As Range
Dim startcol As Long
Dim endcol As Long
Dim rngname As String
Dim IDcellcolm As Long
Dim IDcellrow As Long
Dim IDcellrng As Range
Dim namesrng As Range
Dim lastrow As Long
Dim str1 As String
Dim refsto As String
str1 = "Range_"
Set ws = Sheets("Sheet1")
With Sheets("Sheet1")
.Activate
Set rng = .UsedRange
End With
For Each celle In rng
If celle = "ID#" Then
IDcellcolm = celle.Column
IDcellrow = celle.Row
lastrow = celle.End(xlDown).Row
End If
Next celle
Set namesrng = Range(Cells(IDcellrow, IDcellcolm + 1), Cells(IDcellrow, IDcellcolm + 1).End(xlToRight).Offset(0, -1))
For Each celle In namesrng
If celle <> celle.Offset(0, -1) Then
startcol = celle.Column
endcol = 0
rngname = str1 & celle
End If
If celle <> celle.Offset(0, 1) Then
endcol = celle.Column
End If
If startcol > 0 And endcol > 0 Then
With Sheets("Sheet1")
Set rng2 = .Range(.Cells(IDcellrow + 1, startcol), .Cells(lastrow, endcol))
refsto = "Sheet1!" & rng2.Address
MsgBox "Refers to " & refsto
ActiveWorkbook.Names.Add Name:=rngname, RefersTo:=Worksheets("Sheet1").Range(.Cells(IDcellrow + 1, startcol), .Cells(lastrow, endcol))
End With
End If
Next celle
End Sub
named-ranges-06-NU-.xls
If you are experiencing a similar issue, please ask a related question
Join the community of 500,000 technology professionals and ask your questions.