0

Excel では、複数の範囲から連結された値を qsort する最適な方法があります。a
) 連結された値は異なる必要があります
b) 各連結された値には、それを囲むオプションの前後のテキスト (区切り文字) を含めることができ
ます c) 連結された値は並べ替えられます (qsort) ）。

以下の DISTINCT_CONCAT 関数で a) と b) を達成しましたが、c) qsort はコーディングされていません。以下のコードで、できればパラメーターの前後にCollection Add メソッドを使用して qsort (冗長ではない) する最適な方法はありますか。どんなアイデアでも大歓迎です。うまくいけば、このコードが将来、同様の問題を抱えている他の人に役立つことを願っています。

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 - true の場合、セル値 123 は「123」として表示されます"、それ以外の場合は 123
cellValueRange - 範囲のテキスト値を使用して連結される 1 つまたは複数の範囲 戻り値: 連結された文字列

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

OK、それまでの間、個別の範囲値のコレクションの簡単な並べ替え関数を思いつきました。関数 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");

DISTINCT_CONCAT は、制限付きのネイティブ Excel 関数 CONCATENATE を使用するよりも最適なソリューションを記述しました。 

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 に答える