Страницы: 1
RSS
VBA. Поиск самого часто встречающегося слова в умной таблице
 
Господа, здравствуйте обращался к поиску нужного решения не нашёл.

Есть умная таблица из двух столбцов. Первый столбец "номер отправления", второй "Склад".
Необходимо выяснить все уникальные значение в столбце 1.
Далее запустить цикл на каждое уникальное значение из столбца 1.
Далее определить самое часто встречающееся название склада в столбце 2, соответствующее текущему уникальному номеру отправлению в цикле.
P.S Необходимости использовать Умную таблицу нет, она выгружается из power query. Можно предварительно превратить в диапазон.

Вот что у меня получилось: Застрял на последнем шаге. Файл с примером прилагаю.
Код
count = WorksheetFunction.CountA(ThisWorkbook.Sheets("WBApi").Columns(1))
'присваиваем переменной myRange диапазон ячеек с исходным списком элементов
Set myRange = ThisWorkbook.Sheets("WBApi").Range("A2:A" & count)
Set myRange2 = ThisWorkbook.Sheets("WBApi").Range("B2:B" & count)
'заполняем новую коллекцию уникальными элементами
    On Error Resume Next
    For Each myCell In myRange
    myCollection.Add CStr(myCell.Value), CStr(myCell.Value)
        Next myCell
        On Error GoTo 0
            For Each element In myCollection
        
            ThisWorkbook.Sheets("WBApi").ListObjects("WBApi__2").Range.AutoFilter Field:=1, Criteria1:=element
            'Фильтруем таблицу
            sklad = WorksheetFunction.Index(Range2, WorksheetFunction.Match( _
            WorksheetFunction.Max(WorksheetFunction.CountIf(Range2, Range2)), _
            WorksheetFunction.CountIf(Range2, Range2), 0))
            ' Данная функция выше не работает и врятле заработает т.к Анализирует не промежуточные итоги а диапазон.
            occ = occ + 1
            ThisWorkbook.Sheets("WBApi").Cells(occ, 5) = myCollection
            ThisWorkbook.Sheets("WBApi").Cells(occ, 5) = sklad
            Next element
End Sub
 
Господа, помогите пожалуйста.
 
может так подойдёт с результирующей таблицей на листе?

Код
Sub Test()
    Dim objColl_ID As New Collection, objColl_Office_name As New Collection
    Dim arrData, i As Long, arrResult, vItemID, vItemOfficeName, iRow As Long
    Dim myMax As Long, myMaxText As String
    
    With ActiveSheet
        arrData = .Range("A1").CurrentRegion
        'заполняем новую коллекцию уникальными ID
        On Error Resume Next
        For i = 2 To UBound(arrData)
            objColl_ID.Add arrData(i, 1), CStr(arrData(i, 1))
        Next i
                
        'заполняем новую коллекцию уникальными Office_name
        For i = 2 To UBound(arrData)
            objColl_Office_name.Add arrData(i, 2), CStr(arrData(i, 2))
        Next i
        On Error GoTo 0
                
        ReDim arrResult(1 To UBound(arrData), 1 To 3)
        
        .Range("F:H").Clear 'очищаем столбцы F:H
        
        For Each vItemID In objColl_ID
            For Each vItemOfficeName In objColl_Office_name
                iRow = iRow + 1
                arrResult(iRow, 1) = vItemID
                arrResult(iRow, 2) = vItemOfficeName
                arrResult(iRow, 3) = 0
                For i = 2 To UBound(arrData)
                    If arrData(i, 1) = vItemID Then
                        If arrData(i, 2) = vItemOfficeName Then
                            arrResult(iRow, 3) = arrResult(iRow, 3) + 1
                            If arrResult(iRow, 3) > myMax Then
                                myMax = arrResult(iRow, 3)
                                myMaxText = arrResult(iRow, 1) & " - " & arrResult(iRow, 2) & " - " & arrResult(iRow, 3) & " раза"
                            End If
                        End If
                    End If
                Next i
            Next vItemOfficeName
        Next vItemID
        'вывод результата на лист
        .Range("F1").Resize(iRow, 3).Value = arrResult
    End With
    MsgBox myMaxText, vbInformation, "Самое частое"
End Sub
Изменено: New - 17.10.2021 20:05:10
 
А если все за один проход?
Код
Sub NumberPost()
Set dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
Set Dic3 = CreateObject("Scripting.Dictionary")
count = WorksheetFunction.CountA(ThisWorkbook.Sheets("WBApi").Columns(1))
arr = ThisWorkbook.Sheets("WBApi").Range("A2:B" & count)
With dic1
For i = 1 To UBound(arr)
    If Not .Exists(arr(i, 1)) Then
        .Add arr(i, 1), CreateObject("Scripting.Dictionary")
        Dic2.Add arr(i, 1), arr(i, 2)
        Dic3.Add arr(i, 1), 1
    End If
        .Item(arr(i, 1)).Item(arr(i, 2)) = .Item(arr(i, 1)).Item(arr(i, 2)) + 1
        If .Item(arr(i, 1)).Item(arr(i, 2)) > Dic3(arr(i, 1)) Then
            Dic2.Item(arr(i, 1)) = arr(i, 2)
            Dic3.Item(arr(i, 1)) = dic1.Item(arr(i, 1)).Item(arr(i, 2))
        End If
Next
d = .keys
End With
For Each dd In d
Debug.Print dd, Dic2(dd), Dic3(dd)
Next
End Sub
Изменено: БМВ - 17.10.2021 20:43:07
По вопросам из тем форума, личку не читаю.
 
БМВ, допиши внизу строку End Sub
 
Цитата
New написал:
допиши внизу
10x . Copy Past подвел :-)
По вопросам из тем форума, личку не читаю.
 
БМВ, дополнил твой код с выводом MsgBox с самым частым перемещением товара на склад

Код
Sub NumberPost()
    Dim oDic1 As Object, oDic2 As Object, oDic3 As Object
    Dim LastRow As Long, arrData, i As Long, arrTemp, vItem
    Dim myMax As Long, myMaxText As String
    
    Set oDic1 = CreateObject("Scripting.Dictionary") 'уникальные по столбцу A
    Set oDic2 = CreateObject("Scripting.Dictionary") 'уникальные по столбцу B
    Set oDic3 = CreateObject("Scripting.Dictionary") 'кол-во раз
    
    With ActiveSheet
        LastRow = .Cells(.Rows.count, 1).End(xlUp).Row
        arrData = .Range("A1:B" & LastRow)
    End With
   
    For i = 2 To UBound(arrData)
        If Not oDic1.Exists(arrData(i, 1)) Then
            oDic1.Add arrData(i, 1), CreateObject("Scripting.Dictionary")
            oDic2.Add arrData(i, 1), arrData(i, 2)
            oDic3.Add arrData(i, 1), 1
        End If
        oDic1.Item(arrData(i, 1)).Item(arrData(i, 2)) = oDic1.Item(arrData(i, 1)).Item(arrData(i, 2)) + 1
        If oDic1.Item(arrData(i, 1)).Item(arrData(i, 2)) > oDic3(arrData(i, 1)) Then
            oDic2.Item(arrData(i, 1)) = arrData(i, 2)
            oDic3.Item(arrData(i, 1)) = oDic1.Item(arrData(i, 1)).Item(arrData(i, 2))
            myMaxText = arrData(i, 1) & " - " & oDic2.Item(arrData(i, 1)) & " - " & oDic3.Item(arrData(i, 1)) & " раз"
        End If
    Next
    
    arrTemp = oDic1.keys

    For Each vItem In arrTemp
        Debug.Print vItem, oDic2(vItem), oDic3(vItem)
    Next
    
    Set oDic1 = Nothing
    Set oDic2 = Nothing
    Set oDic3 = Nothing
    
    MsgBox myMaxText, vbInformation, "Самое частое"
End Sub
Изменено: New - 17.10.2021 20:58:40
 
New, такой вывод только для  условия отсортированного списка.
   
Код
Set oDic2 = CreateObject("Scripting.Dictionary") 'уникальные по столбцу B
-  не совсем корректный коммент, это текущее значение по столбцу б с максимальным повторением.
По вопросам из тем форума, личку не читаю.
 
Господа, вы маги! попытаюсь разобраться в структуре кода, дабы не докучать такими вопросами. Спасибо
 
БМВ, тогда Max запомним вот так

Код
Sub NumberPost()
    Dim oDic1 As Object, oDic2 As Object, oDic3 As Object
    Dim LastRow As Long, arrData, i As Long, arrTemp, vItem
    Dim myMax As Long, myMaxText As String, arrResult
    
    Set oDic1 = CreateObject("Scripting.Dictionary")
    Set oDic2 = CreateObject("Scripting.Dictionary")
    Set oDic3 = CreateObject("Scripting.Dictionary")
    
    With ActiveSheet
        LastRow = .Cells(.Rows.count, 1).End(xlUp).Row
        arrData = .Range("A1:B" & LastRow)
    End With
   
    For i = 2 To UBound(arrData)
        If Not oDic1.Exists(arrData(i, 1)) Then
            oDic1.Add arrData(i, 1), CreateObject("Scripting.Dictionary")
            oDic2.Add arrData(i, 1), arrData(i, 2)
            oDic3.Add arrData(i, 1), 1
        End If
        oDic1.Item(arrData(i, 1)).Item(arrData(i, 2)) = oDic1.Item(arrData(i, 1)).Item(arrData(i, 2)) + 1
        If oDic1.Item(arrData(i, 1)).Item(arrData(i, 2)) > oDic3(arrData(i, 1)) Then
            oDic2.Item(arrData(i, 1)) = arrData(i, 2)
            oDic3.Item(arrData(i, 1)) = oDic1.Item(arrData(i, 1)).Item(arrData(i, 2))
            If oDic3.Item(arrData(i, 1)) > myMax Then
                myMax = oDic3.Item(arrData(i, 1))
                myMaxText = arrData(i, 1) & " - " & oDic2.Item(arrData(i, 1)) & " - " & oDic3.Item(arrData(i, 1)) & " раз"
            End If
        End If
    Next
        
    arrTemp = oDic1.keys
    ReDim arrResult(1 To UBound(arrTemp) + 1, 1 To 3)
    i = 0
    For Each vItem In arrTemp
        Debug.Print vItem, oDic2(vItem), oDic3(vItem)
        i = i + 1
        arrResult(i, 1) = vItem: arrResult(i, 2) = oDic2(vItem): arrResult(i, 3) = oDic3(vItem)
    Next
    
    'вывод результата на лист
    ActiveSheet.Range("F1").Resize(UBound(arrResult), UBound(arrResult, 2)).Value = arrResult
    
    Set oDic1 = Nothing
    Set oDic2 = Nothing
    Set oDic3 = Nothing
    
    MsgBox myMaxText, vbInformation, "Самое частое"
End Sub
Изменено: New - 17.10.2021 21:21:44
 
OFF
БМВ, так-так-так… Есть подозрение, что ты перешёл на личности и сунул нос, куда не надо :D
Изменено: Jack Famous - 18.10.2021 09:21:32
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
Jack Famous написал:
Есть подозрение, что ты перешёл на личности и сунул нос, куда не надо
мой код, мои правила :D  , так что ...... Ты хоть посомтри внимательно, это New причесал мой вариант.
По вопросам из тем форума, личку не читаю.
 
Цитата
БМВ: это New причесал мой вариант
оба наскандалили  :D
Теперь ты видишь, что поправлять - нормально, а реагировать на такое, подрывным пуканом - нет?  ;)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Off
Jack Famous, когда я говорил что правильная коррекция это не нормально? Я ваще считаю что глаз замыливается и бревна не видать порой. Любой взгляд со стороны помогает. Особенно тот который на недочет указывает, а не тот как тут.
Цитата
БМВ написал:
оба наскандалили  
-и где был скандал, мне кажется оба нормально отнеслись к замечаниям и примечаниям.
Изменено: БМВ - 18.10.2021 16:47:16
По вопросам из тем форума, личку не читаю.
 
Доброе время суток, коллеги.
А в чём профит в трёх словарях?
Код
Public Sub GetInfoK()
    Dim pDict As Object
    Dim ids As Variant
    Dim offices As Variant
    Dim pTable As ListObject
    Dim vMax As Long, sMaxKey As String
    Dim i As Long, sKey As String
    Set pTable = ActiveSheet.ListObjects("WBApi__2")
    ids = pTable.ListColumns("gi_id").DataBodyRange.Value
    offices = pTable.ListColumns("office_name").DataBodyRange.Value
    Set pDict = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(ids, 1)
        sKey = ids(i, 1) & "|" & offices(i, 1)
        pDict(sKey) = pDict(sKey) + 1
        If pDict(sKey) > vMax Then
            vMax = pDict(sKey)
            sMaxKey = sKey
        End If
    Next
    Debug.Print Replace$(sMaxKey, "|", " — ") & " = " & vMax
End Sub
 
Андрей VG, если нужно найти единственный макcимальный, то да, нет смысла, я искал для каждого уникального из А максимальное количество из B. согласно
Цитата
Артур Кузнецов написал:
Далее определить самое часто встречающееся название склада в столбце 2, соответствующее текущему уникальному номеру отправлению в цикле.
Изменено: БМВ - 18.10.2021 16:45:39
По вопросам из тем форума, личку не читаю.
 
Цитата
БМВ: когда я говорил что правильная коррекция это не нормально?
да недавно - ты точно помнишь) Там нормальная коррекция была  :)
По ссылке ты вспылил, однако  :D Лётчик, конечно, кругом неправ, но я удивлён, что тебя вывел  8-0
Цитата
БМВ: где был скандал
ващет это шутка была и очередная отсылка к тому случаю  :D
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
Jack Famous написал:
Лётчик, конечно, кругом неправ, но я удивлён, что тебя вывел
да блин не первый раз тупит, а туда ж, учить....
По вопросам из тем форума, личку не читаю.
 
Михаил, спасибо.
Страницы: 1
Наверх