2

値が次のようなセルの列があります。

a
a
b
b
c
c
c
c
d
e
f
f

等

重複していない値を取得して、新しい列に貼り付けたいと考えています。このための私の擬似コードは次のとおりです。

ActiveSheet.Range("a1").End(xlDown).Select
aend = Selection.Row
for acol= 1 to aend
    ActiveSheet.Range("b1").End(xlDown).Select
    bend = Selection.Row
        'if Cells(1,acol).Value <> any of the values in the range Cells(2,1).Value
        'to Cells(2,bend).Value, then add the value of Cells(1,acol) to the end of 
        'column b.

この論理は理にかなっていますか？コメント部分のコーディング方法がわかりません。これが最も効率的な方法ではない場合、誰かがより良い方法を提案できますか？本当にありがとう！

4

4 に答える 4

14

使用している Excel のバージョンに応じて、組み込みの Excel 機能を使用して必要なものを取得できます。ソリューション全体は、VBA のスキルのレベルによって異なります。

エクセル2003：

Advancedfilter範囲のメソッド (ドキュメント) を使用して、一意の値を取得し、それらをターゲット領域にコピーできます。例：

With ActiveSheet
    .Range("A1", .Range("A1").End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("B1"), Unique:=True
End With

B1一意の値をコピーする列の最初のセルはどこですか。この方法の唯一の問題は、コピー元の列の最初の行 ("A1") がコピー先の範囲にコピーされることです。これは、AdvancedFilter メソッドが最初の行がヘッダーであると想定しているためです。

したがって、追加のコード行を追加すると、次のようになります。

With ActiveSheet    
    .Range("A1", .Range("A1").End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("B1"), Unique:=True
    .Range("B1").Delete Shift:=xlShiftUp
End With

エクセル 2007 / 2010 :

上記と同じ方法を使用することも、RemoveDuplicates方法 (ドキュメント) を使用することもできます。これは AdvancedFilter メソッドと似ていRemoveDuplicatesますが、インプレースで動作する点が異なります。つまり、ソース列の複製を作成してからフィルタリングを実行する必要があります。次に例を示します。

With ActiveSheet
    .Range("A1", .Range("A1").End(xlDown)).Copy Destination:=.Range("B1")
    .Range("B1", .Range("B1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
End With

最後のパラメーターHeaderは、ソース データの最初のセルがコピー先にコピーされるかどうかを制御します (true に設定されている場合、このメソッドは AdvancedFilter メソッドと同様です)。

「より純粋な」方法を求めている場合は、VBAを使用するCollectionかdictionary、他の誰かがこれで解決策を提供すると確信しています。

于 2012-08-06T22:24:36.770 に答える
3

リストから一意のアイテムを取得するために、重複するキーを持つことができないコレクションを使用します。各アイテムをコレクションに追加し、キーが重複している場合のエラーを無視してみてください。次に、一意の値のサブセットを含むコレクションが作成されます

Sub MakeUnique()

    Dim vaData As Variant
    Dim colUnique As Collection
    Dim aOutput() As Variant
    Dim i As Long

    'Put the data in an array
    vaData = Sheet1.Range("A1:A12").Value

    'Create a new collection
    Set colUnique = New Collection

    'Loop through the data
    For i = LBound(vaData, 1) To UBound(vaData, 1)
        'Collections can't have duplicate keys, so try to
        'add each item to the collection ignoring errors.
        'Only unique items will be added
        On Error Resume Next
            colUnique.Add vaData(i, 1), CStr(vaData(i, 1))
        On Error GoTo 0
    Next i

    'size an array to write out to the sheet
    ReDim aOutput(1 To colUnique.Count, 1 To 1)

    'Loop through the collection and fill the output array
    For i = 1 To colUnique.Count
        aOutput(i, 1) = colUnique.Item(i)
    Next i

    'Write the unique values to column B
    Sheet1.Range("B1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput

End Sub
于 2012-08-06T22:02:57.393 に答える
1

単純な配列を使用し、すべての文字を調べて、現在の文字が配列内にあるかどうかを確認します。

Sub unique_column()

Dim data() As Variant 'array that will store all of the unique letters

c = 1

Range("A1").Select


Do While ActiveCell.Value <> ""

    ReDim Preserve data(1 To c) As Variant

    If IsInArray(ActiveCell.Value, data()) = False Then 'we are on a new unique letter and will add it to the array
        data(c) = ActiveCell.Value
        c = c + 1
    End If

    ActiveCell.Offset(1, 0).Select

Loop

'now we can spit out the letters in the array into a new column

Range("B1").Value = "Unique letters:"

Dim x As Variant

Range("B2").Select

For Each x In data()

    ActiveCell.Value = x

    ActiveCell.Offset(1, 0).Select

Next x

Range("A1").Select

c = c - 1

killer = MsgBox("Processing complete!" & vbNewLine & c & "unique letters applied.", vbOKOnly)


End Sub

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean

    IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)

End Function
于 2015-08-06T18:33:33.870 に答える
1

完全を期すために、Scripting.Dictionary メソッドを投稿します。これは、VBA.Collection を使用するための最も一般的な代替手段であり、通常の操作でエラー処理に頼る必要がなくなります。

Scripting.Dictionary オブジェクトを使用して重複を含む Excel 範囲から一意の値を返す VBA 関数:

Option Explicit


'           Author: Nigel Heffernan
'           May 2012  http://excellerando.blogspot.com

'           **** THIS CODE IS IN THE PUBLIC DOMAIN ****
'
'           You are advised to segregate this code from
'           any proprietary or commercially-confidential
'           source code, and to label it clearly. If you
'           fail do do so, there is a risk that you will
'           impair your right to assert ownership of any
'           intellectual property embedded in your work,
'           or impair your employers or clients' ability
'           to do so if the intellectual property rights
'           in your work have been assigned to them.
'

Public Function UniqueValues(SourceData As Excel.Range, _
                             Optional Compare As VbCompareMethod = vbBinaryCompare _
                             ) As Variant
Application.Volatile False

' Takes a range of values and returns a single-column array of unique items.

' The returned array is the expected data structure for Excel.Range.Value():
' a 1-based 2-Dimensional Array with dimensions 1 to RowCount, 1 to ColCount

' All values in the source are treated as text, and uniqueness is determined
' by case-sensitive comparison. To change this, set the Compare parameter to
' to 1, the value of the VbCompareMethod enumerated constant 'VbTextCompare'

' Error values in cells are returned as "#ERROR" with no further comparison.
' Empty or null cells are ignored: they do not appear in the returned array.


Dim i As Long, j As Long, k As Long
Dim oSubRange As Excel.Range
Dim arrSubRng As Variant
Dim arrOutput As Variant
Dim strKey    As String
Dim arrKeys   As Variant

Dim dicUnique As Object

' Note the late-binding as 'object' - best practice is to create a reference
' to the Windows Scripting Runtime: this allows you to declare dictUnique as
' Dim dictUnique As Scripting.Dictionary  and instantiate it using the 'NEW'
' keyword instead of CreateObject, giving slightly better speed & stability.

If SourceData Is Nothing Then
    Exit Function
End If

If IsEmpty(SourceData) Then
    Exit Function
End If

Set dicUnique = CreateObject("Scripting.Dictionary")
    dicUnique.CompareMode = Compare

For Each oSubRange In SourceData.Areas   ' handles noncontiguous ranges

    'Use Worksheetfunction.countA(oSubRange) > 0 to ignore empty ranges

    If oSubRange.Cells.Count = 1 Then
        ReDim arrSubRng(1 To 1, 1 To 1)
        arrSubRng(1, 1) = oSubRange.Cells(1, 1).Value
    Else
        arrSubRng = oSubRange.Value
    End If

    For i = LBound(arrSubRng, 1) To UBound(arrSubRng, 1)
        For j = LBound(arrSubRng, 2) To UBound(arrSubRng, 2)
            If IsError(arrSubRng(i, j)) Then
                dicUnique("#ERROR") = vbNullString
            ElseIf IsEmpty(arrSubRng(i, j)) Then
                ' no action: empty cells are ignored
            Else
            '   We use the error-tolerant behaviour of the Dictionary:
            '   If you query a key that doesn't exist, it adds the key
                dicUnique(CStr(arrSubRng(i, j))) = vbNullString
            End If
        Next j
    Next i

    Erase arrSubRng

Next oSubRange

If dicUnique.Count = 0 Then
    UniqueValues = Empty
Else
    arrKeys = dicUnique.keys
    dicUnique.RemoveAll

    ReDim arrOutput(1 To UBound(arrKeys) + 1, 1 To 1)
    For k = LBound(arrKeys) To UBound(arrKeys)
        arrOutput(k + 1, 1) = arrKeys(k)
    Next k
    Erase arrKeys

    UniqueValues = arrOutput

    Erase arrOutput
End If

Set dicUnique = Nothing

End Function

いくつかのメモ:

  1. これは、要求した単一列の範囲だけでなく、任意の Excel 範囲のコードです。
  2. この関数は、VBA では処理が難しいエラーのあるセルを許容します。
  3. これは Reddit ではありません。コメントを読むことができます。コメントは理解を助けるものであり、一般的に正気を保つのに役立ちます。

于 2015-08-06T18:13:13.523 に答える