Страницы: 1
RSS
Как с помощью VBA фильтровать уникальные значения по столбцу L и добавлять их в столбец A на втором листе?
 
Добрый день! Подскажите, как средствами VBA сделать следующие действия.

- Фильтровать уникальные значения по столбцу L и добавлять их в любой условный столбец на втором листе, к примеру в столбец A.
- Для каждого уникального значения из столбца L выбирать соответствующие ему значения из столбца K (строк может получиться несколько) и добавлять эти значения в столбец B на втором листе.

Для других столбцов нужно делать примерно то же самое, но я уже сориентируюсь по аналогии этих двух.
Может, у кого-нибудь есть примеры кода?
Нужно именно средствами VBA, т.к. таблицы обычно огромные.
Изменено: amarok36 - 11.03.2025 12:13:10
 
Цитата
написал:
- Фильтровать уникальные значения по столбцу L и добавлять их в любой условный столбец на втором листе, к примеру в столбец A.
Код
Sub myFilter()
    Dim aUniq As Variant
    aUniq = GetUniq(Sheets(1).Range("L:L"))
    If IsEmpty(aUniq) Then Exit Sub
    
    PrintArray Sheets(2).Range("A:A"), aUniq
End Sub

Private Function GetUniq(rr As Range) As Variant
    Dim arr As Variant
    arr = Intersect(rr, rr.Parent.UsedRange).Value
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        Select Case arr(ya, 1)
        Case "", 0
        Case Else
            dic(arr(ya, 1)) = Empty
        End Select
    Next
    
    If dic.Count > 0 Then
        ReDim arr(1 To dic.Count, 1 To 1)
        For ya = 1 To UBound(arr, 1)
            arr(ya, 1) = dic.Keys()(ya - 1)
        Next
        
        GetUniq = arr
    End If
End Function

Private Sub PrintArray(rr As Range, arr As Variant)
    With rr.Cells(rr.Rows.Count, 1).End(xlUp).Cells(2, 1).Resize(UBound(arr, 1), UBound(arr, 2))
        .Value = arr
    End With
End Sub


Вариант полаконичнее.
Скрытый текст
Изменено: МатросНаЗебре - 11.03.2025 13:04:22
 
Цитата
написал:
- Для каждого уникального значения из столбца L выбирать соответствующие ему значения из столбца K (строк может получиться несколько) и добавлять эти значения в столбец B на втором листе.
Код
'v2
Sub myFilter()
    Dim aUniq As Variant
    aUniq = GetUniq(Sheets(1).Range("L:L"), Sheets(1).Range("K:K"))
    If IsEmpty(aUniq) Then Exit Sub
    
    PrintArray Sheets(2).Range("A:A"), aUniq
End Sub

Private Function GetUniq(rr As Range, rb As Range) As Variant
    Dim arr As Variant, brr As Variant
    arr = Intersect(rr, rr.Parent.UsedRange).Value
    brr = Intersect(Intersect(rr, rr.Parent.UsedRange).EntireRow, rb.EntireColumn).Value
    
    Dim dic As Object, bic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        Select Case arr(ya, 1)
        Case "", 0
        Case Else
            Select Case brr(ya, 1)
            Case "", 0
            Case Else
                
                If dic.Exists(arr(ya, 1)) Then
                    Set bic = dic(arr(ya, 1))
                Else
                    Set bic = CreateObject("Scripting.Dictionary")
                End If
                bic(brr(ya, 1)) = Empty
                
                Set dic(arr(ya, 1)) = bic
            End Select
        End Select
    Next
    
    If dic.Count > 0 Then
        ReDim arr(1 To dic.Count, 1 To 1)
        brr = arr
        For ya = 1 To UBound(arr, 1)
            arr(ya, 1) = dic.Keys()(ya - 1)
            brr(ya, 1) = Join(dic.Items()(ya - 1).Keys(), ", ")
        Next
        
        GetUniq = Array(arr, brr)
    End If
End Function

Private Sub PrintArray(rr As Range, arr As Variant)
    With rr.Cells(rr.Rows.Count, 1).End(xlUp).Cells(2, 1).Resize(UBound(arr(0), 1), UBound(arr(0), 2))
        .Value = arr(0)
        .Columns(2).Value = arr(1)
    End With
End Sub
 
Большое спасибо! Постараюсь доработать под остальные условия.
Страницы: 1
Читают тему
Наверх