如何对给定范围进行排序，并将单元格名称与要排序的单元格相关联?

Question

对于给定的 A2：Q26 范围，我需要一个宏来按字母顺序组织它。此外，我还重命名了 A 列中的所有单元格。 示例 - (A2 = Rep_1，A3 = Rep_2，等等)。

当我尝试传统的排序方法时，单元格名称会保留在原位，并且不会与相应的单元格信息一起传输，这与"剪切/粘贴"不同。

由于我在 A 列中有其他宏绑定到单元格名称，并且每个宏都通过"选择更改"设置为一个按钮。由于在选择所需单元格时名称未传输，因此由于在排序过程中未传输单元格名称，因此会发生错误的相应操作。

我可以编写一个宏代码，可以移动名称，单元格按字母顺序对列表进行排序？任何建议都会有所帮助！

Answer 1

保留名称

• 调整常量部分中的"源工作表名称"cSheet(而不是Sheet1)。
• 程序将仅影响单元格A2:A26中的名称，但是 将按列A(1)对A2:Q26范围进行排序。
• 这是单向操作，没有撤消，因此请创建备份。
• 简而言之，程序会将A1:A26的值复制到第 1 个 列(源数组)，然后写入 名称 来自A1:A26到数组的第二列并删除它们，然后在排序之后A1:Q26按列A，将A1:A26的排序值复制到另一个数组 (目标数组)并使用两个数组中的数据在 按要求的方式。
• 运行代码后，在"即时"窗口中研究结果以 看看你做了什么。
• 下面的 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

添加名称(救援)

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

Answer 2

您可以在排序算法中添加代码，以便在每次交换 2 个单元格的位置后交换范围的名称。像这样：(在我的示例中，我交换了 A1 和 A2 的值和名称)

Dim temp1 As String, temp2 As String, tempValue As String
With ThisWorkbook.ActiveSheet 'Change the ActiveSheet to the sheet you're working on
'Swapping the values
tempValue = .Range("A1").Value2
.Range("A1").Value2 = .Range("A2").Value2
.Range("A2").Value2 = tempValue
'Swapping the names
temp1 = .Range("A1").Name.Name
temp2 = .Range("A2").Name.Name 'This Line and the next one are necessary unlike swapping the values because you can't have 2 different ranges with the same name
.Range("A1").Name.Name = "temp"
.Range("A2").Name.Name = temp1
.Range("A1").Name.Name = temp2
End With