Excel VBA宏对多个范围测试值的不同连接进行排序

Question

在 Excel 中，有一种最佳方法可以对来自多个范围的串联值进行 qsort 排序，其中
a) 连接的值必须是不同的
b) 每个连接的值可以有一个可选的前后文本（分隔符）来包围它
c) 对连接的值进行排序 (qsort)。

我已经在下面的 DISTINCT_CONCAT 函数中实现了 a) 和 b)，但是 c) qsort 没有编码。 在下面的代码中是否有最佳的 qsort 方法（不详细），最好使用 Collection Add method before 和 after 参数。任何想法将不胜感激希望此代码将来可以帮助其他人解决类似问题。

Excel 公式示例：

对于电子表格单元格
A1:A4 包含 21、12、32、12
B2:B4 包含 14, 08, 12

公式宏功能
=DISTINCT_CONCAT("$list.add(";"); "&CHAR(10);TRUE;Sheet1!A1:A4;Sheet2!B2:B4)

将在另一个电子表格单元格中显示一个不同的范围值列表，如
$list.add("21");
$list.add("12");
$list.add("32");
$list.add("14");
$list.add("08");

我的偏好是该函数返回一个不同范围值的排序字符串
$list.add("08");
$list.add("12");
$list.add("14");
$list.add("21");
$list.add("32");

没有 qsort 的 DISTINCT_CONCAT 函数

目的：一个范围内所有单元格值的不同连接，之前和可选 文字后
输入：
beforeCellValue - 出现在单元格值之前的可选文本
afterCellValue - 出现在单元格值之后的可选文本
cellValueInQuotes - 如果为 true，则单元格值 123 显示为“123”，否则为 123
cellValueRange - 要连接的一个或多个范围，使用范围的文本值 返回：连接字符串

Public Function DISTINCT_CONCAT( ByVal beforeCellValue As String, ByVal afterCellValue As String, ByVal cellValueInQuotes As Boolean, ParamArray cellValueRange() As Variant) As String

  Dim c As Collection, i As Long, cell As Range
  Set c = New Collection
  For i = LBound(cellValueRange) To UBound(cellValueRange)
    For Each cell In cellValueRange(i)
        If Len(cell.text) > 0 Then
            On Error Resume Next
            c.Add cell.value, cell.text ' distinct collection (no duplicates)
            On Error GoTo 0
        End If
    Next cell
    Set cell = Nothing
  Next i

  Dim returnText As String
  Dim value As Variant
  For Each value In c
    If cellValueInQuotes Then
        returnText = returnText & beforeCellValue & Chr(34) & value & Chr(34) & afterCellValue
    Else
        returnText = returnText & beforeCellValue & value & afterCellValue
    End If
  Next value
  DISTINCT_CONCAT = returnText
End Function 

Answer 1

Scripting.Dictionary 在没有任何错误处理的情况下强制键的唯一性，但它无法排序。

.NET System.Collections.ArrayList 有一个使用快速排序的 Sort 方法。

这假定引用了Microsoft Scripting Runtime。

Public Function DISTINCT_CONCAT(ByVal beforeCellValue As String, ByVal afterCellValue As String, ByVal cellValueInQuotes As Boolean, ParamArray cellValueRange() As Variant) As String
Dim i As Long, cell As Variant, dict As New Dictionary, items As Variant, al As Variant, item As Variant
Dim delimiter As String, returnText As String

For i = 0 To UBound(cellValueRange)
    For Each cell In cellValueRange(i)
        dict(cell.Text) = cell.value
    Next
Next

Set al = CreateObject("System.Collections.ArrayList")
items = dict.items
For Each item In items
    al.Add item
Next
al.Sort

'Doing this here limits the number of string concatenations, as does using
'the Join function
If cellValueInQuotes Then
    beforeCellValue = beforeCellValue & Chr(34)
    afterCellValue = Chr(34) & afterCellValue
End If

DISTINCT_CONCAT = beforeCellValue & Join(al.ToArray, afterCellValue & beforeCellValue) & afterCellValue
End Function

不要重新发明轮子，除非你需要一个更好的。 :)

Answer 2

这很奇怪。我尝试在 Collection 对象上使用传统的排序方法，但是当它删除一个键并尝试添加另一个键时，代码会停止执行而不会出错。诡异的。由于您试图仅保留唯一值，因此我将 Collection 对象保留在那里。但是，我将内容放入数组中，对数组进行排序，然后使用数组显示值。

Option Explicit

Public Function DISTINCT_CONCAT(ByVal beforeCellValue As String, ByVal afterCellValue As String, ByVal cellValueInQuotes As Boolean, ParamArray cellValueRange() As Variant) As String

    Dim c As Collection, i As Long, cell As Range
    Set c = New Collection
    For i = LBound(cellValueRange) To UBound(cellValueRange)
    For Each cell In cellValueRange(i)
        If Len(cell.Text) > 0 Then
            On Error Resume Next
            c.Add cell.value, cell.Text ' distinct collection (no duplicates)
            On Error GoTo 0
        End If
    Next cell
    Set cell = Nothing
    Next i



    Dim arr() As Long
    ReDim arr(1 To c.Count)
    For i = 1 To c.Count
        arr(i) = c(i)
    Next i

    ' sort array
    Dim j As Long, k As Long
    Dim temp As Long
    For j = LBound(arr) To UBound(arr)
        For k = j + 1 To UBound(arr)
            If (arr(j) > arr(k)) Then
                temp = arr(k)
                arr(k) = arr(j)
                arr(j) = temp
            End If
        Next k
    Next j


    Dim returnText As String
    Dim value As Variant

    For i = LBound(arr) To UBound(arr)
        If cellValueInQuotes Then
            returnText = returnText & beforeCellValue & Chr(34) & arr(i) & Chr(34) & afterCellValue
        Else
            returnText = returnText & beforeCellValue & arr(i) & afterCellValue
        End If
    Next i
    DISTINCT_CONCAT = returnText
End Function

Answer 3

好的，与此同时，我想出了一个快速排序功能，用于不同范围值的集合。函数 DISTINCT_CONCAT 现在采用额外的排序类型参数 [0（无排序）、1（升序排序）、2（降序排序）]。

这可能对某人有帮助。这是代码。如果有人认为有更优化的解决方案，请随时更新代码。

其中电子表格单元格

Sheet1 - A1:A4 包含 21、12、32、12
Sheet2 - B2:B4 包含 14、08、12

公式

=DISTINCT_CONCAT("$list.add(""";"""); "&CHAR(10);1;Sheet1!A1:A4;Sheet2!B2:B4

现在将返回一个由不同范围值组成的连接排序的 asc 字符串，每个值的任一侧都有所需的文本为

$list.add("08");
$list.add("12");
$list.add("14");
$list.add("21");
$list.add("32");

我使用有限的本机 Excel 函数 CONCATENATE 编写了 DISTINCT_CONCAT 一个更优化的解决方案。

Purpose: Distinct Concatenation of all cell values in a range, with optional before and after text
Inputs:  
   beforeValue - optional text to appear before cell value
   afterValue - optional text to appear after cell value
   sortType - sort distinct cell values, use 0 (no sort), 1 (sort ascending), 2 (sort descending)
   rangeOfValues- one or more ranges to be concatenated, using the text value of the range
Returns: a range of values as a distinct concatenated string optionally sorted with before and after text

Public Function DISTINCT_CONCAT( _
      ByVal beforeValue As String, _
      ByVal afterValue As String, _
      ByVal sortType As Integer, _
      ParamArray rangeOfValues() As Variant) As String

    ' add range of values to distinct collection
    Dim c As Collection, i As Long, cell As Range
    Set c = New Collection
    For i = LBound(rangeOfValues) To UBound(rangeOfValues)
        For Each cell In rangeOfValues(i)
            If Len(cell.text) > 0 Then
                On Error Resume Next
                c.Add cell.value, cell.text ' ignores duplicates
                On Error GoTo 0
            End If
        Next cell
        Set cell = Nothing
    Next i

    ' optional sort
    Call Sort(c, sortType)

    ' concatenation distinct values into a string with optional before and after value delimitors
    Dim text As String
    Dim value As Variant
    For Each value In c
        text = text & beforeValue & value & afterValue
    Next value
    DISTINCT_CONCAT = text
End Function

Private Function Sort(ByRef c As Collection, ByVal sortType As Integer)
    Dim i As Long, j As Long

    If sortType < 1 And sortType > 2 Then Exit Function

    For i = 1 To c.Count - 1
        For j = i + 1 To c.Count
            If sortType = 1 Then
                If c(i) > c(j) Then Swap c, i, j
            ElseIf sortType = 2 Then
                If c(i) < c(j) Then Swap c, i, j
            End If
        Next
    Next
End Function

Private Function Swap(ByRef c As Collection, ByVal i As Long, ByVal j As Long)
    c.Add c(j), , , i
    c.Add c(i), , , j + 1
    c.Remove i
    c.Remove j
End Function