Reputation: 21

How do I sort a given range alphebetically and keep the cell names tied to the cells being sorted?

For the given range of A2:Q26 I need a macro to organize this alphabetically. Additionally I have renamed all the cells in column A. example - (A2 = Rep_1, A3 = Rep_2, etc).

When I try a traditional sorting method, the cell names stay in place and do not transfer with the corresponding cell information unlike "cut/paste".

As I have other macros tied to cell names in column A and each is set up as a button via "selectionchange". Because of the name not transferring when I select the desired cell, the wrong corresponding action occurs because the cell name was not transferred during sorting.

Is there a macro code I could write that would either move the name with the cell sorting the list alphabetically? Any suggestions would be helpful!

Upvotes: 0

Answers (2)

VBasic2008

Reputation: 54883

Preserve Names

Adjust the Source Worksheet Name cSheet in the constants section (instead of Sheet1).
The program as is will affect only names in cells A2:A26, but will sort the range A2:Q26 by column A(1).
This is a one way operation, there is no undo, so create backups.
In short, the program will copy the values of A1:A26 to the 1st column of an array (Source Array), then write the Names from A1:A26 to the 2nd column of the array and delete them, and after the sort of A1:Q26 by column A, will copy the sorted values of A1:A26 to another array (Target Array) and using the data in both arrays create new names in the way as requested.
After you run the code, study the results in the Immediate window to see what you have done.
The 3 programs below PreserveNames are just some tools you might find useful, as I did. They are not needed to run PreserveNames.

The Code

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

Add Names (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

Delete Names

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

List Names (in Immediate window)

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

Upvotes: 1

NadAlaba

Reputation: 302

You can add code in your sorting algorithm that swaps the names of ranges after each time you swap positions of 2 cells. Like this: (In my example I'm swapping the values and names of A1 and 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