Сохранить имена
- Настройте имя исходного листа
cSheet в разделе констант (вместо Sheet1). - Программа как есть будет влиять только на имена в ячейках
A2:A26, но будет сортировать диапазон A2:Q26 по столбцу A (1). - Это односторонняя операция, отмены нет, поэтому создавать резервные копии .
- Короче говоря, программа скопирует значения
A1:A26 в 1-й столбец массива ( Source Array ), а затем запишет имена из A1:A26 во второй столбец массива и удалите их, и после сортировки A1:Q26 по столбцу A скопируйте отсортированные значения A1:A26 в другой массив ( TargetМассив ) и использование данных в обоих массивах создает новые имена в соответствии с запросом. - После запуска кода изучите результаты в окне Immediate, чтобы увидеть, что вы сделали.
- 3 программы ниже
PreserveNames - это всего лишь некоторые инструменты, которые вы могли бы найти полезными, как и я.Они не нужны для запуска PreserveNames.
Код
Sub PreserveNames()
Const cSheet As String = "Sheet1" ' Source Worksheet Name
Const cRange As String = "A2:Q26" ' Sort Range Address
Const cSort As Long = 1 ' Sort Column Number
Dim rngSort As Range ' Sort RAnge
Dim rngST As Range ' Source/Target Range
Dim vntS As Variant ' Source Array
Dim vntT As Variant ' Target Array
Dim i As Long ' Source Array Row Counter
Dim k As Long ' Target Array Row Counter
Dim strP As String ' RefersTo Sheet Pattern
Dim strR As String ' RefersTo String
'**********************
' Source/Target Range '
'**********************
' Create a reference to Sort Range.
Set rngSort = ThisWorkbook.Worksheets(cSheet).Range(cRange)
' Calculate Source/Target Range ("cSort"-th column (range) of Sort Range).
Set rngST = rngSort.Columns(cSort)
'*************************
' RefersTo Sheet Pattern '
'*************************
' Check if Worksheet Name does NOT contain a space character.
If InStr(1, cSheet, " ") = 0 Then ' Does NOT contain a space.
strP = "=" & cSheet & "!"
Else ' DOES contain a space.
strP = "='" & cSheet & "'!"
End If
'****************
' Source Array '
'***************
' Copy values of Source/Target Range to Source Array.
vntS = rngST
' Resize Source Array i.e. add one more column for Name.
ReDim Preserve vntS(1 To UBound(vntS), 1 To 2)
' Loop through rows of Source Array (cells of Source/Target Range).
For i = 1 To UBound(vntS) ' or "For i = 1 To rngST.Rows.Count"
With rngST.Cells(i)
' Suppress error that would occur if current cell
' of Source/Target Range does NOT contain a Name.
On Error Resume Next
' Write Name of current cell of Source/Target Range
' to 2nd column of Source Array.
vntS(i, 2) = .Name.Name
' Suppress error continuation.
If Err Then
On Error GoTo 0
Else
' Delete Name in current cell of Source/Target Range.
.Name.Delete
End If
End With
Next
' Display contents of Source Array to Immediate window.
Debug.Print String(20, "*") & vbCr & "Source Array" & vbCr & String(20, "*")
For i = 1 To UBound(vntS)
Debug.Print vntS(i, 1) & " | " & vntS(i, 2)
Next
'*******
' Sort '
'*******
' Sort Sort Range by Sort Column.
rngSort.Sort rngSort.Cells(cSort)
'***************
' Target Array '
'***************
' Copy values of Source/Target Range to Target Array.
vntT = rngST
' Loop through rows of Target Array (cells of Source/Target Range).
For k = 1 To UBound(vntT)
' Loop through rows of Source Array (cells of Source/Target Range).
For i = 1 To UBound(vntS)
' Check if current value of Target Array is equal to current value
' of Source Array, where current value means value at current
' row in 1st column of either array.
If vntT(k, 1) = vntS(i, 1) Then
' Suppress error that would occur if value at current row
' in 2nd column of Source Array (Name) is equal to "".
If vntS(i, 2) <> "" Then
' Concatenate RefersTo Sheet Pattern (strP) and the address
' of current cell range in row k, to RefersTo String (strR).
strR = strP & rngST.Cells(k).Address
' Write value at current row in 2nd column of Source
' Array to the Name property, and RefersTo String to the
' RefersTo property of a newly created name.
ThisWorkbook.Names.Add vntS(i, 2), strR
End If
' Since the values in Source Array are (supposed to be) unique,
' stop looping through Source Array and go to next row
' of Target Array.
Exit For
End If
Next
Next
' Display contents of Target Array to Immediate window.
Debug.Print String(20, "*") & vbCr & "Target Array" & vbCr & String(20, "*")
For i = 1 To UBound(vntS)
Debug.Print vntT(i, 1)
Next
' Display Value, Name and RefersTo of each cell in Source/Target Range.
Debug.Print String(60, "*") & vbCr & "Current Data" & vbCr & String(60, "*")
For i = 1 To rngST.Rows.Count
With rngST.Cells(i)
On Error Resume Next
Debug.Print "Value: '" & rngST.Cells(i) & "' | Name: " _
& .Name.Name & "' | RefersTo: '" & .Name.RefersTo & "'"
On Error GoTo 0
End With
Next
End Sub
Добавить имена (Rescue)
Sub AddNamesToCellRange()
Const cSheet As String = "Sheet1" ' Source Worksheet Name
Const cRange As String = "A2:A26" ' Source Range Address
Const cName As String = "Rep_" ' Name Pattern
Dim i As Long
With ThisWorkbook.Worksheets(cSheet).Range(cRange)
' Check if Worksheet Name does NOT contain a space character.
If InStr(1, cSheet, " ") = 0 Then ' Does NOT contain a space.
' Loop through rows of Source Worksheet.
For i = 1 To .Rows.Count
' Add name to current cell range.
.Parent.Parent.Names.Add cName & i, "=" & cSheet & "!" _
& .Cells(i).Address
Next
Else ' DOES contain a space.
' Loop through rows of Source Worksheet.
For i = 1 To .Rows.Count
' Add name to current cell range.
.Parent.Parent.Names.Add cName & i, "='" & cSheet & "'!" _
& .Cells(i).Address
Next
End If
End With
End Sub
Удалить имена
Sub DeleteNamesInWorkbook()
Dim nm As Name
Dim str1 As String
With ThisWorkbook
For Each nm In .Names
str1 = "Name '" & nm.Name & "' deleted."
nm.Delete
Debug.Print str1
Next
End With
End Sub
Список имен (в немедленном окне)
Sub ListNamesInWorkbook()
Dim nm As Name
With ThisWorkbook
For Each nm In .Names
Debug.Print "Name: '" & nm.Name & "', RefersTo: '" _
& nm.RefersTo & "'."
Next
End With
End Sub