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

Question

Я хочу получить список различных значений на основе критериев, например: у меня есть список магазинов, и я хочу получить только различные значения на основе критериев продавца "BOULANGER".

Sub distinctValues()

Dim LastRow As Long
Dim Crit1 As String

LastRow = Sheets("SOURCE").Cells(Rows.Count, "B").End(xlUp).Row

Sheets("SOURCE").Range("B1:B" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("TEST").Range("E2"), CopyToRange:=Sheets("TEST").Range("A12"), Unique:=True

End Sub

Answer 1

Я подозреваю, что ваш диапазон критериев неправильно настроен и / или не указан в вашем рабочем листе.

В .AdvancedFilter у вас есть:

Range(Crit1)

, что, согласно вашемукод, будет интерпретироваться как:

Range("BOULANGER")

Это предполагает, что у вас есть Именованный диапазон где-то в вашей тестовой таблице с именем BOULANGER и ссылается на две ячейки в столбце, первая из которых содержит Store а второй содержит BOULANGER

Если вы правильно настроили этот код, ваш код работает.

Обратите внимание, что на снимке экрана с критериями первая ячейка содержит Criteriaа не Store.Таким образом, даже если вы настроили заданный диапазон для охвата этих двух ячеек, он не будет работать, поскольку первая строка должна иметь имя, идентичное имени фильтруемого столбца.

Answer 2

Это должно выполнить то, что вы пытаетесь сделать;см. комментарии в коде.

Sub ListUniqueValues()
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Sheet1") 'change as needed
Set ws2 = ThisWorkbook.Sheets("Sheet2") 'change as needed

    ws1.Range("B1", ws1.Cells(Rows.Count, "B").End(xlUp)).Copy ws2.Range("C1") 'copy the full range from sheet1
    ws2.Range("C1", ws2.Cells(Rows.Count, "C").End(xlUp)).RemoveDuplicates Columns:=Array(1), Header:=xlNo 'remove duplicates

    Dim lRow As Long
    lRow = ws2.Cells(Rows.Count, 3).End(xlUp).Row 'set lastrow variable

        For i = lRow To 1 Step -1 'Da Loop, from bottom to top
            'change the cell address after "Like" to the cell address where you put your store criteria
            'the line will delete any store name that is not like your store criteria
            'the (& "*") inserts the wildcard after your store criteria you type in your designated cell, e.g. "BOULANGER*"
            If Not ws2.Cells(i, 3).Value Like ws2.Cells(1, 1).Value & "*" Then  '
                ws2.Cells(i, 3).Delete 'delete the cells that do not match your store criteria
            End If
        Next i
End Sub 

Answer 3

Если вы пытаетесь получить уникальный диапазон, содержащий ключевое слово, что-то вроде этого должно работать.

Option Explicit

Private Sub OutputUniqueRange(SearchRange As Range, Keyword As String, OutputRange As Range)
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim cell As Range

    For Each cell In SearchRange
        With cell
            If InStr(1, .Value2, Keyword, vbTextCompare) > 0 And Not dict.exists(.Value2) Then dict.Add .Value2, .Value2
        End With
    Next

    If dict.Count = 0 Then Exit Sub
    OutputRange.Range(OutputRange.Cells(1, 1).Address).Resize(dict.Count, 1) = Application.Transpose(dict.items())
End Sub

Public Sub TestSub()
    Dim SearchRange         As Range
    Dim Keyword             As String
    Dim OutputRange         As Range

    Keyword = "Boulanger"
    Set SearchRange = ThisWorkbook.Sheets("Sheet1").Range("A2:A34")
    Set OutputRange = ThisWorkbook.Sheets("Sheet1").Range("B2")

    OutputUniqueRange SearchRange, Keyword, OutputRange
End Sub