Question

在我的Excel表（见下文）中有不同地方的名字：5x Alpen，7x Big Sur，2x Britany ......

我想自动订购这些地方，使一个地方的名字尽可能远离彼此。例如。两个Alpen细胞之间将有尽可能多的其他地方。那可能吗？如果是：怎么做？

PS：在我的完整列表中有几百个单元格。因此，强烈建议使用自动化解决方案。

Answer 1

免责声明： StackOverflow 不代码编写服务，您应该真正尝试对您的问题做些什么，而不是仅仅将其放入。但是，它似乎很有趣，它让我思考了一分多钟，因此最后我决定尝试一下。

让我们说你的输入范围看起来像左列，你想得到正确的列（我完全忽略了2.点）：

所以，这些是您需要采取的步骤：

从Range("A1:A47")获取值并将它们放入字典中;
按值排序字典;
开始循环浏览字典，搜索下一个空闲位置（GiveMeNextFreePosition()）。找到它后，将字典的值分配给array finalRange;
遍历数组finalRange并使用offset函数将值写入下一列;

Option Explicit

Public Sub TestMe()
    'with a reference for MicrosoftScriptingRuntime
    Dim dict As New Scripting.Dictionary
    Dim myCell As Range
    Dim initialRange As Range

    Set initialRange = Range("A1:A47")
    For Each myCell In initialRange
        If dict.Exists(myCell.value) Then
            dict(myCell.value) = dict(myCell.value) + 1
        Else
            dict.Add myCell.value, 1
        End If
    Next myCell
    'sort the dictionary
    Set dict = SortDictionaryByValue(dict, xlDescending)
    Dim finalRange As Variant
    ReDim finalRange(initialRange.Count)
    Dim myKey   As Variant
    For Each myKey In dict.Keys
        Dim cnt         As Long
        Dim placesLeft  As Long
        While dict(myKey) > 0
            dict(myKey) = dict(myKey) - 1
            cnt = GiveMeNextFreePosition(finalRange, myKey)
            finalRange(cnt) = myKey
        Wend
    Next myKey

    Dim rowCounter  As Long
    rowCounter = initialRange.Cells(1, 1).Row - 1
    For Each myCell In initialRange.Offset(0, 1)
        myCell = finalRange(rowCounter)
        rowCounter = rowCounter + 1
    Next myCell        
End Sub

Public Function GiveMeNextFreePosition(ByRef arr As Variant, _
                                       ByVal myInput As String) As Long

    Dim cnt     As Long: cnt = -1
    Dim reserve As Long

    For cnt = LBound(arr) To UBound(arr)
        If arr(cnt) = vbNullString Then
            reserve = cnt
            If cnt <> LBound(arr) Then
                If arr(cnt - 1) <> myInput Then
                    GiveMeNextFreePosition = cnt
                    Exit Function
                End If
            Else
                GiveMeNextFreePosition = 0
                Exit Function
            End If
        End If
    Next cnt

    GiveMeNextFreePosition = reserve

End Function

Sort Dictionary功能：

Public Function SortDictionaryByValue(dict As Object _
     , Optional sortorder As XlSortOrder = xlAscending) As Object

    On Error GoTo eh

    Dim arrayList As Object
    Set arrayList = CreateObject("System.Collections.ArrayList")

    Dim dictTemp As Object
    Set dictTemp = CreateObject("Scripting.Dictionary")

    ' Put values in ArrayList and sort
    ' Store values in tempDict with their keys as a collection
    Dim key As Variant, value As Variant, coll As Collection
    For Each key In dict

        value = dict(key)

        ' if the value doesn't exist in dict then add
        If dictTemp.Exists(value) = False Then
            ' create collection to hold keys
            ' - needed for duplicate values
            Set coll = New Collection
            dictTemp.Add value, coll

            ' Add the value
            arrayList.Add value

        End If

        ' Add the current key to the collection
        dictTemp(value).Add key

    Next key

    ' Sort the value
    arrayList.Sort

    ' Reverse if descending
    If sortorder = xlDescending Then
        arrayList.Reverse
    End If

    dict.RemoveAll

    ' Read through the ArrayList and add the values and corresponding
    ' keys from the dictTemp
    Dim item As Variant
    For Each value In arrayList
        Set coll = dictTemp(value)
        For Each item In coll
            dict.Add item, value
        Next item
    Next value

    Set arrayList = Nothing

    ' Return the new dictionary
    Set SortDictionaryByValue = dict

Done:
    Exit Function
eh:
    If Err.Number = 450 Then
        Err.Raise vbObjectError + 100, "SortDictionaryByValue" _
                , "Cannot sort the dictionary if the value is an object"
    End If
End Function

Excel：排列最大距离的文本单元格

1 个答案: