Некоторые картинки не загружаются из РФ и РК, используйте VPN.

пятница, 6 января 2023 г.

Excel VBA Найти имя группировки

Допустим есть сгруппированная таблица, где в столбце С уникальные идентификаторы (артикулы) и нужно получить имя группировки, вот функция это и делает. Применение: =FindGroupName(ячейка_шаблон;диапазон)

Function FindGroupName(RCell As Range, RRange As Range)
    Dim Pattern As String, Result As Integer
    Result = 0
    Pattern = RCell.Value
    If RRange.Columns.Count > 1 Then
        RRange = RRange.Columns(1)
    End If
    For Each fCell In RRange.Cells
        If fCell.Value = Pattern Then
            For StrResultRange = fCell.Row To 1 Step -1
                If RRange.Rows(StrResultRange) = "" Then
                    Result = RRange.Rows(StrResultRange).Row
                    Exit For
                End If
            Next StrResultRange
            If Result > 0 Then
                Exit For
            End If
        End If
    Next
    If Result > 0 Then
        FindGroupName = Worksheets(RRange.Parent.Name).Range("A" & Result).Value
    Else
        FindGroupName = ""
    End If
    
End Function

Как то так

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

Function FindGroupName(RCell As Range, RRange As Range)
    Dim Pattern As String, Result As Integer, NumEmpStr As Integer
    Dim arr
    Pattern = RCell.Value
    strEnd = Cells(RRange.Count, 1).End(xlUp).Row
    
    'copy to array
    arr = RRange.Cells(RRange.Row, 1).Resize(strEnd).Value
        
    For numStr = 1 To strEnd Step 1
        If arr(numStr, 1) = vbNullString Then
            NumEmpStr = numStr
        End If
        If StrComp(arr(numStr, 1), Pattern, vbTextCompare) = 0 Then
            Result = NumEmpStr
            Exit For
        End If
    Next numStr
    If Result > 0 Then
        FindGroupName = Worksheets(RRange.Parent.Name).Range("A" & Result).Value
    Else
        FindGroupName = ""
    End If
    
End Function

Третий вариант, добавлен два параметра ТолькоАртикул (читай номер строки) и префикс, котрый прибавляется к этому артикулу. Применение: =FindGroupName(F2;All!C:C;"MI";ИСТИНА) - результат MI7

Function FindGroupName(RCell As Range, RRange As Range, Pref As String, OnlyArticle As Boolean)
    Dim Pattern As String, Result As Integer, NumEmpStr As Integer, arr
    Pattern = RCell.Value
    strEnd = Cells(RRange.Count, 1).End(xlUp).Row
    
    'copy to array
    arr = RRange.Cells(RRange.Row, 1).Resize(strEnd).Value
        
    For numStr = 1 To strEnd Step 1
        If arr(numStr, 1) = vbNullString Then
            NumEmpStr = numStr
        End If
        If StrComp(arr(numStr, 1), Pattern, vbTextCompare) = 0 Then
            Result = NumEmpStr
            Exit For
        End If
    Next numStr
    If Result > 0 Then
        If OnlyArticle Then
            FindGroupName = Pref & Result
        Else
            FindGroupName = Worksheets(RRange.Parent.Name).Range("A" & Result).Value
        End If
    Else
        FindGroupName = ""
    End If
    
End Function


Комментариев нет:

Отправить комментарий