0

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

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

示例 Excel 公式：

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

，公式宏函数 将在另一个电子表格单元格中显示一个不同的范围值列表，如 $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");
=DISTINCT_CONCAT("$list.add(";"); "&CHAR(10);TRUE;Sheet1!A1:A4;Sheet2!B2:B4)













没有 qsort 的 DISTINCT_CONCAT 函数

目的：一个范围内所有单元格值的不同连接，带有可选的前后文本
输入：
beforeCellValue - 出现在单元格值之前的
可选文本 afterCellValue - 出现在单元格值之后的可选文本
cellValueInQuotes - 如果为真，则单元格值 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

4

3 回答 3

2

AScripting.Dictionary在没有任何错误处理的情况下强制键的唯一性，但它不能被排序。

.NETSystem.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

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

于 2012-12-18T00:37:25.987 回答
0

这是一个奇怪的。我尝试在 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
于 2012-12-17T22:04:02.910 回答
0

好的，与此同时，我为不同范围值的集合提出了一个快速排序功能。函数 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

于 2012-12-17T23:31:30.403 回答