Извлекать уникальные значения из столбца на основе критериев - PullRequest
Новая
       8

Извлекать уникальные значения из столбца на основе критериев

0 голосов
/ 12 ноября 2018

Я хотел бы извлечь уникальные значения на основе критериев.Это то, что я до сих пор: 

Sub test()
    Dim x As Variant
    Dim objdict As Object
    Dim lngrow As Long
    With Sheets("Sheet1")
        Set objdict = CreateObject("Scripting.Dictionary")
        x = Application.Transpose(.Range("A1", .Range("A1").End(xlDown)))
        For lngrow = 1 To UBound(x, 1)
            objdict(x(lngrow)) = 1
        Next
        .Range("C1:C" & objdict.Count) = Application.Transpose(objdict.keys)
    End With
End Sub

Ниже того, что я хотел бы достичь:

img

Как вы можете видеть значения в столбце Aкритерии указаны в столбце B, а уникальные значения - в столбце C. Может кто-нибудь показать мне, что мне нужно изменить в моем коде?

1 Ответ

0 голосов
/ 12 ноября 2018

Ты почти у цели!См. Комментарии в приведенном ниже коде: 

Option Explicit

Sub Test()
    Dim x As Variant
    Dim objDict As Object
    Dim lngRow As Long

    Set objDict = CreateObject("Scripting.Dictionary")

    With Sheet1 '<== You can directly use the (Name) property of the worksheet as seen from the VBA editor.
        x = .Range(.Cells(1, 1), .Cells(.Rows.Count, 2).End(XlDirection.xlUp)).Value

        For lngRow = 1 To UBound(x, 1)
            If x(lngRow, 2) = 1 Then '<== Example criteria: value is 1 in column B.
                objDict(x(lngRow, 1)) = 1 '<== Don't know if this is significant in your case (I typically assign True).
            End If
        Next

        .Range(.Cells(1, 3), .Cells(objDict.Count, 3)).Value = Application.Transpose(objDict.Keys)
    End With

    'Cleanup.
    Set objDict = Nothing
End Sub

Обратите внимание, что я заменил строки, используемые в Range(), на числовые индексы (строка, столбец), что, по-моему, является лучшей практикой.

...