0

Sheet1 の列 A に並べ替えられていない名前のリストがあります。これらの名前の多くは、リストに複数回表示されます。

Sheet2 列 AI では、重複する値のない名前のアルファベット順に並べ替えられたリストが必要です。

VBAを使用してこれを達成する最適な方法は何ですか?

これまでに見た方法には次のものがあります。

  1. CStr(name) をキーとしてコレクションを作成し、範囲をループして各名前を追加しようとします。一意ではないエラーがある場合は無視し、そうでない場合は範囲​​を 1 セルずつ拡張して名前を追加します
  2. (1) と同じですが、エラーを無視します。ループが完了すると、一意の値のみがコレクションに含まれます。次に、コレクション全体を範囲に追加します
  3. 範囲でワークシートの一致機能を使用する: 一致しない場合は、範囲を 1 セル分拡張し、名前を追加します。
  4. データタブの「重複を削除」ボタンのシミュレーションでしょうか？（これは調べていません）
4

2 に答える 2

2

私は VBA のディクショナリ オブジェクトがとても気に入っています。ネイティブでは利用できませんが、非常に有能です。への参照を追加する必要があり、次のMicrosoft Scripting Runtimeようなことができます。

Dim dic As Dictionary
Set dic = New Dictionary
Dim srcRng As Range
Dim lastRow As Integer

Dim ws As Worksheet
Set ws = Sheets("Sheet1")

lastRow = ws.Cells(1, 1).End(xlDown).Row
Set srcRng = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, 1))

Dim cell As Range

For Each cell In srcRng
    If Not dic.Exists(cell.Value) Then
        dic.Add cell.Value, cell.Value   'key, value
    End If
Next cell

Set ws = Sheets("Sheet2")    

Dim destRow As Integer
destRow = 1
Dim entry As Variant

'the Transpose function is essential otherwise the first key is repeated in the vertically oriented range
ws.Range(ws.Cells(destRow, 1), ws.Cells(dic.Count, 1)) = Application.Transpose(dic.Items)
于 2012-05-10T01:37:18.357 に答える
0

あなたが示唆したように、ある種の辞書が鍵となります。私はコレクションを使用します-それは（Scripting.Dictionaryとは対照的に）組み込みであり、仕事をします。

「最適」とは「高速」を意味する場合、2番目のトリックは各セルに個別にアクセスしないことです。代わりにバッファを使用してください。以下のコードは、数千行の入力があっても高速になります。

コード：

' src is the range to scan. It must be a single rectangular range (no multiselect).
' dst gives the offset where to paste. Should be a single cell.
' Pasted values will have shape N rows x 1 column, with unknown N.
' src and dst can be in different Worksheets or Workbooks.
Public Sub unique(src As Range, dst As Range)
    Dim cl As Collection
    Dim buf_in() As Variant
    Dim buf_out() As Variant
    Dim val As Variant
    Dim i As Long

    ' It is good practice to catch special cases.
    If src.Cells.Count = 1 Then
        dst.Value = src.Value   ' ...which is not an array for a single cell
        Exit Sub
    End If
    ' read all values at once
    buf_in = src.Value
    Set cl = New Collection
    ' Skip all already-present or invalid values
    On Error Resume Next
    For Each val In buf_in
        cl.Add val, CStr(val)
    Next
    On Error GoTo 0

    ' transfer into output buffer
    ReDim buf_out(1 To cl.Count, 1 To 1)
    For i = 1 To cl.Count
        buf_out(i, 1) = cl(i)
    Next

    ' write all values at once
    dst.Resize(cl.Count, 1).Value = buf_out

End Sub
于 2012-05-10T07:33:30.017 に答える