Страницы: 1
RSS
Частота встречаемости продуктов в заказах
 
Всем привет!

Буду очень благодарна, если вы мне подскажите, как создать таблицу/формулу со следующими данными. И в принципе, можно ли такую формулу создать?!
Суть:
Есть продажи (номер заказа, состав заказа (артикул; шт и т.д.))
Хочется проанализировать составы заказов, чтобы выявить продукты, которые в одном заказе встречаются вместе чаще всего. Проще говоря, какие продукты клиенты заказывают вместе.
Например: в 3 заказах из 10 встречаются комбо товаров Товар1 + Товар3 + Товар5 (под словом Товар имею ввиду артикулы)
Частота товаров: 2 3 4 6
Не знаю, как задать формулу, которая будет в таблице выдавать артикулы по частоте использования в одном заказе.
Из таблицы важный параметр, который должен получаться на выходе - это артикулы.
Типо
5 раз - Товар1 и Товар6
2 раза - Товар1 и Товар2
10 раз - Товар3, Товар4, Товар11 и Товар21
и т.д.

При этом не учитывать заказы, в котором есть только 1 продукт.
Тут важно выявить комбо продукты.

Во вложении пример таблицы.
Изменено: Wine Wine - 10.06.2021 14:55:41
 
А что от туда сбежали сбежали?
По вопросам из тем форума, личку не читаю.
 
Да, скрывать не буду, даже текст особо не переписывала. Писала и на другом форуме, тк туда я обращалась уже раза 2-3 по разным вопросам.
Но на текущий момент все же моя задачка не решилась и я решила обратиться к вам  :)   может у вас найдется другое\ие решения, с помощью которых получится реализовать идею.

п.с: макрос я сегодня научилась делать с помощью вашего форума  :D  
 
Код
Option Explicit

Sub ГруппаКомбинация()
    Dim y As Long
    Dim arr As Variant
    With ActiveSheet
        y = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        arr = .Range(.Cells(1, 1), .Cells(y, 2))
    End With
    
    Dim wb As Workbook
    Set wb = Workbooks.Add(1)
    With wb.Sheets(1)
        Dim r As Range
        Set r = .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
        r = arr
        
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range(r.Columns(1).Address(0, 0)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add Key:=Range(r.Columns(2).Address(0, 0)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        
            .SetRange Range(r.Address(0, 0))
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        arr = r
        r.Clear
    End With
    
    Dim e As Long
    Dim i As Long
    Dim j As Long
    Dim s As String
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For y = 2 To UBound(arr, 1) - 1
        For e = y To UBound(arr, 1) - 1
            If arr(e + 1, 1) <> arr(e, 1) Then Exit For
        Next
        If e > y Then
            For i = y To e - 1
            For j = i + 1 To e
                s = Join(Array(arr(i, 2), arr(j, 2)), vbTab)
                dic.Item(s) = dic.Item(s) + 1
            Next
            Next
            y = e
        End If
    Next
    
    If dic.Count = 0 Then Exit Sub
    Dim aKey As Variant
    Dim aItm As Variant
    aKey = dic.Keys()
    aItm = dic.Items()
    
    ReDim arr(1 To dic.Count, 1 To 3)
    Dim brr As Variant
    For y = 1 To UBound(arr, 1)
        brr = Split(aKey(y - 1), vbTab)
        arr(y, 1) = brr(0)
        arr(y, 2) = brr(1)
        arr(y, 3) = aItm(y - 1)
    Next
    
    r.Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    
    With wb.Sheets(1)
        Set r = .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
        
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range(r.Columns(3).Address(0, 0)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .SortFields.Add Key:=Range(r.Columns(1).Address(0, 0)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add Key:=Range(r.Columns(2).Address(0, 0)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        
            .SetRange Range(r.Address(0, 0))
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        'arr = r
    End With
    r.Columns("A:B").AutoFit
    
    wb.Saved = True
End Sub
Изменено: МатросНаЗебре - 10.06.2021 16:13:49
 
Код
Option Explicit
Sub FindRepeats()
    Dim lrow As Long
    Dim dicOrders
    Set dicOrders = CreateObject("Scripting.Dictionary")
    lrow = Cells(Rows.Count, 7).End(xlUp).Row
    If lrow > 1 Then
        Range("G2:G" & lrow).Clear
    End If
    Dim colGoods As Collection
    Dim c_ As Variant
    lrow = Cells(Rows.Count, 1).End(xlUp).Row
    '  Формируем словарь заказов
    For Each c_ In Range("A2:A" & lrow)
        If dicOrders.exists(c_.Value) Then
            dicOrders(c_.Value).Add Range("B" & c_.Row).Value
        Else
            Set colGoods = New Collection
            colGoods.Add Range("B" & c_.Row).Value
            dicOrders.Add c_.Value, colGoods
        End If
    Next c_

    Dim dicPNs
    Set dicPNs = CreateObject("Scripting.Dictionary")
    Dim colPNs As New Collection
    Dim i As Integer
    '  Удаляем заказы с 1 товаром
    '  Формируем коллекцию артикулов
    For i = dicOrders.Count - 1 To 0 Step -1
        If dicOrders.items()(i).Count = 1 Then
            dicOrders.Remove dicOrders.keys()(i)
        Else
            On Error Resume Next
            Dim pn_ As Variant
            For Each pn_ In dicOrders.items()(i)
                colPNs.Add pn_, pn_
            Next pn_
            On Error GoTo 0
        End If
    Next i
    
    Dim j As Integer
    Dim order_ As Variant
    '  Ищем повторения
    For Each order_ In dicOrders.items()
        For i = 1 To order_.Count
            For j = i + 1 To order_.Count
                Dim combPN As String
                combPN = order_.Item(i) & " + " & order_.Item(j)
                dicPNs(combPN) = dicPNs(combPN) + 1
            Next j
        Next i
    Next order_
    '  Выводим кол-во повторений для артикулов
    For i = 0 To dicPNs.Count - 1
        Range("G" & (i + 2)) = dicPNs.keys()(i)
        Range("H" & (i + 2)) = dicPNs.items()(i)
    Next i
End Sub

Поправил, в соответствии с задачей. Сначала не разобрался...
Изменено: vokilook - 10.06.2021 17:19:38
 
Wine Wine, здравствуйте
Знакома ли Вам эта статья Поиск и подсчет самых частых значений ?
 
Тут вряд ли формулы справятся. Можно по отдельности решать задачи: какие пары артикулов встречаются чаще всего, какие тройки артикулов встречаются чаще всего... При увеличении количества анализируемых вместе артикулов будет расти (и значительно) количество анализируемых данных.
В #4 коллега дал пример решения для пар и троек артикулов.
Изменено: sokol92 - 10.06.2021 16:27:43
Владимир
 
vokilook, cпасибо за предложение) Сейчас попробую макрос

IKor, здравствуйте. Нет, такую статью не видела. В целом, сама идея с группировками пока для меня новая. Разбираюсь. Спасибо за ссылку, поизучаю )

МатросНаЗебре, написала вам ответ, не поняла куда он улетел и не отображается.
Спасибо большое за такой крутой макрос.  8-0 Моя жизнь никто не будет прежней  :idea:

Один вопрос остался, мб я недопонимаю и нужно дополнительно отредактировать
С помощью этого варианта выводятся комбинации 2 товаров.
Как сделать отдельно для 3, 4 и 6? Какую часть кода изменить/добавить? под это условие.

Я бы их запускала отдельно, формируя несколько файлов по отдельности

Ваш коллега ниже как раз написал об этом
Цитата
sokol92 написал:
Тут вряд ли формулы справятся. Можно по отдельности решать задачи: какие пары артикулов встречаются чаще всего, какие тройки артикулов встречаются чаще всего...
Спасибо за совет))  
Изменено: vikttur - 10.06.2021 18:12:23
 
Так код выглядит для троек. По аналогии изменения можно сделать и для 4 и 6.
Код
Sub ТройкаКомбинация()
    Dim y As Long
    Dim arr As Variant
    With ActiveSheet
        y = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        arr = .Range(.Cells(1, 1), .Cells(y, 2))
    End With
    
    Dim wb As Workbook
    Set wb = Workbooks.Add(1)
    With wb.Sheets(1)
        Dim r As Range
        Set r = .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
        r = arr
        
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range(r.Columns(1).Address(0, 0)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add Key:=Range(r.Columns(2).Address(0, 0)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        
            .SetRange Range(r.Address(0, 0))
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        arr = r
        r.Clear
    End With
    
    Dim e As Long
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim s As String
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For y = 2 To UBound(arr, 1) - 1
        For e = y To UBound(arr, 1) - 1
            If arr(e + 1, 1) <> arr(e, 1) Then Exit For
        Next
        If e > y Then
            For i = y To e - 2
            For j = i + 1 To e - 1
            For k = j + 1 To e
                s = Join(Array(arr(i, 2), arr(j, 2), arr(k, 2)), vbTab)
                dic.Item(s) = dic.Item(s) + 1
            Next
            Next
            Next
            y = e
        End If
    Next
    
    If dic.Count = 0 Then Exit Sub
    Dim aKey As Variant
    Dim aItm As Variant
    aKey = dic.Keys()
    aItm = dic.Items()
    
    ReDim arr(1 To dic.Count, 1 To 4)
    Dim brr As Variant
    For y = 1 To UBound(arr, 1)
        brr = Split(aKey(y - 1), vbTab)
        arr(y, 1) = brr(0)
        arr(y, 2) = brr(1)
        arr(y, 3) = brr(2)
        arr(y, 4) = aItm(y - 1)
    Next
    
    r.Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    
    With wb.Sheets(1)
        Set r = .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
        
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range(r.Columns(4).Address(0, 0)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .SortFields.Add Key:=Range(r.Columns(1).Address(0, 0)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add Key:=Range(r.Columns(2).Address(0, 0)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add Key:=Range(r.Columns(3).Address(0, 0)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        
            .SetRange Range(r.Address(0, 0))
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        'arr = r
    End With
    r.Columns("A:C").AutoFit
    
    wb.Saved = True
End Sub
 
Код
Option Explicit
Sub FindRepeats()
    Dim numberOfPNs As Integer
    ' ----------------------------------------------------
    numberOfPNs = 3                 '  Задать кол-во артикулов (max = 6)
    ' ----------------------------------------------------
    Dim lrow As Long
    Dim dicOrders
    Set dicOrders = CreateObject("Scripting.Dictionary")
    lrow = Cells(Rows.Count, 7).End(xlUp).Row
    If lrow > 1 Then
        Range("G2:H" & lrow).Clear
    End If
    Dim colGoods As Collection
    Dim c_ As Variant
    lrow = Cells(Rows.Count, 1).End(xlUp).Row
    '  Формируем словарь заказов
    For Each c_ In Range("A2:A" & lrow)
        If dicOrders.exists(c_.Value) Then
            dicOrders(c_.Value).Add Range("B" & c_.Row).Value
        Else
            Set colGoods = New Collection
            colGoods.Add Range("B" & c_.Row).Value
            dicOrders.Add c_.Value, colGoods
        End If
    Next c_

    Dim dicPNs
    Set dicPNs = CreateObject("Scripting.Dictionary")
    Dim colPNs As New Collection
    Dim i As Integer
    '  Удаляем заказы с 1 товаром
    '  Формируем коллекцию артикулов
    For i = dicOrders.Count - 1 To 0 Step -1
        If dicOrders.Items()(i).Count < numberOfPNs Then
            dicOrders.Remove dicOrders.Keys()(i)
        Else
            On Error Resume Next
            Dim pn_ As Variant
            For Each pn_ In dicOrders.Items()(i)
                colPNs.Add pn_, pn_
            Next pn_
            On Error GoTo 0
        End If
    Next i
    
    Dim j, k, l, m, n As Integer
    Dim order_ As Variant
    '  Ищем повторения
    For Each order_ In dicOrders.Items()
        For i = 1 To order_.Count
            For j = i + 1 To order_.Count
            For k = j + 1 To order_.Count                                                    '  для трех
'            For l = k + 1 To order_.Count                                                   '  для четырех
'            For m = l + 1 To order_.Count                                                   '  для пяти
'            For n = m + 1 To order_.Count                                                   '  для шести
                Dim combPN As String
                combPN = order_.Item(i) & " + " & order_.Item(j)
                combPN = combPN & " + " & order_.Item(k)                                    '  для трех
'                combPN = combPN & " + " & order_.Item(l)                                   '  для четырех
'                combPN = combPN & " + " & order_.Item(m)                                   '  для пяти
'                combPN = combPN & " + " & order_.Item(n)                                   '  для шести
                dicPNs(combPN) = dicPNs(combPN) + 1
'            Next n                                                                         '  для шести
'            Next m                                                                         '  для пяти
'            Next l                                                                         '  для четырех
            Next k                                                                          '  для трех
            Next j
        Next i
    Next order_
    '  Выводим кол-во повторений для артикулов
    For i = 0 To dicPNs.Count - 1
        Range("G" & (i + 2)) = dicPNs.Keys()(i)
        Range("H" & (i + 2)) = dicPNs.Items()(i)
    Next i
End Sub

Указываем кол-во артикулов:
Код
    ' ----------------------------------------------------
    numberOfPNs = 3                 '  Задать кол-во артикулов (max = 6)
    ' ----------------------------------------------------
А потом снимаем/устанавливаем комментарии для нужных строк:
Код
            For k = j + 1 To order_.Count                                                    '  для трех
'            For l = k + 1 To order_.Count                                                   '  для четырех
'            For m = l + 1 To order_.Count                                                   '  для пяти
'            For n = m + 1 To order_.Count                                                   '  для шести
                Dim combPN As String
                combPN = order_.Item(i) & " + " & order_.Item(j)
                combPN = combPN & " + " & order_.Item(k)                                    '  для трех
'                combPN = combPN & " + " & order_.Item(l)                                   '  для четырех
'                combPN = combPN & " + " & order_.Item(m)                                   '  для пяти
'                combPN = combPN & " + " & order_.Item(n)                                   '  для шести
                dicPNs(combPN) = dicPNs(combPN) + 1
'            Next n                                                                         '  для шести
'            Next m                                                                         '  для пяти
'            Next l                                                                         '  для четырех
            Next k                                                                          '  для трех
 
Цитата
Wine Wine написал:
Спасибо большое за такой крутой макрос.  
:) Вот Вам штука позабористей. Так выглядит код для произвольного количества артикулов.
Код
Option Explicit

Sub Main()
    If Check_VBOM_Access Then
        'CloseWb
        
        Dim n As Variant
        n = InputBox("Введите количество артикулов в комбинации", "Комбинации", 2)
        If Not IsNumeric(n) Then Exit Sub
        If n < 2 Then Exit Sub
        If n > 255 Then Exit Sub
        
        Dim wb As Workbook
        Set wb = MakeWb(n)
        Dim sh As Worksheet
        Set sh = wb.Sheets(1)
        
        Dim dic As Object
        Dim arr As Variant
        'Set dic = GetDic()
        'arr = GetArr(dic)
        
        Set dic = Application.Run("'" & wb.Name & "'!GetDic")
        arr = GetArr(dic)
        
        OutArr sh, arr
    End If
End Sub

Private Sub CloseWb()
    ThisWorkbook.Save
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Name <> ThisWorkbook.Name Then wb.Close False
    Next
End Sub

Private Function MakeWb(ByVal n As Byte) As Workbook
    Dim y As Long
    Dim arr As Variant
    With ActiveSheet
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        If y = 1 Then y = 2
        arr = .Range(.Cells(2, 1), .Cells(y, 2))
    End With
    
    Dim wb As Workbook
    Set wb = Workbooks.Add(1)
    With wb.Sheets(1)
        Dim r As Range
        Set r = .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
        r = arr
        
        With .Sort
            .SortFields.Clear
            Dim x As Variant
            For Each x In Array(1, 2)
                .SortFields.Add Key:=Range(r.Columns(x).Address(0, 0)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            Next
            
            .SetRange Range(r.Address(0, 0))
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
    
    AddCodeToWb wb, n
    
    Set MakeWb = wb
End Function

Function GetDic(sh As Worksheet) As Object
    Dim y As Long
    Dim r As Range
    With sh
        y = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        Set r = .Range(.Cells(1, 1), .Cells(y, 2))
    End With
    Dim arr As Variant
    arr = r
    
    Dim e As Long
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim s As String
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For y = 1 To UBound(arr, 1) - 1
        For e = y To UBound(arr, 1) - 1
            If arr(e + 1, 1) <> arr(e, 1) Then Exit For
        Next
        If e > y Then
            For i = y To e - 2
            For j = i + 1 To e - 1
            For k = j + 1 To e
                s = Join(Array(arr(i, 2), arr(j, 2), arr(k, 2)), vbTab)
                dic.Item(s) = dic.Item(s) + 1
            Next
            Next
            Next
            y = e
        End If
    Next
    Set GetDic = dic
End Function
Function GetArr(dic As Object) As Variant
    If dic.Count = 0 Then Exit Function
    Dim aKey As Variant
    Dim aItm As Variant
    aKey = dic.Keys()
    aItm = dic.Items()

    Dim brr As Variant
    brr = Split(aKey(0), vbTab)
    
    ReDim arr(1 To dic.Count, 1 To UBound(brr) + 2)
    Dim y As Long
    Dim x As Byte
    For y = 1 To UBound(arr, 1)
        brr = Split(aKey(y - 1), vbTab)
        arr(y, 1) = aItm(y - 1)
        For x = 0 To UBound(brr)
            arr(y, 2 + x) = brr(x)
        Next
    Next
    GetArr = arr
End Function

Private Sub OutArr(sh As Worksheet, arr As Variant)
    With sh
        .Cells.Clear
        If IsEmpty(arr) Then Exit Sub
        Dim r As Range
        Set r = .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
        r = arr
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range(r.Columns(1).Address(0, 0)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            Dim x As Long
            For x = 2 To UBound(arr, 2)
                .SortFields.Add Key:=Range(r.Columns(x).Address(0, 0)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            Next
            
            .SetRange Range(r.Address(0, 0))
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        r.Offset(0, 1).EntireColumn.AutoFit
        .Parent.Saved = True
    End With
End Sub

Private Sub AddCodeToWb(wb As Workbook, n As Byte)
    Dim VBProj As Object 'VBIDE.VBProject from library Microsoft Visual Basic for Applications Extensibility 5.3
    Dim VBComp As Object 'VBIDE.VBComponent
    
    Set VBProj = wb.VBProject
    Set VBComp = VBProj.VBComponents.Add(1)
    VBComp.Name = "Frequency"
        
    Dim CodeMod As Object 'VBIDE.CodeModule
    Set CodeMod = VBComp.CodeModule
    
    Dim txt As String
    txt = SubText1(n)
    CodeMod.InsertLines CodeMod.CountOfLines + 1, txt

End Sub

Private Function SubText1(n As Byte) As String
    Dim txt As String
    Dim i As Byte
    
    txt = _
"Function GetDic() As Object" & vbNewLine & _
"    Dim y As Long" & vbNewLine & _
"    Dim r As Range" & vbNewLine & _
"    Dim sh As Worksheet" & vbNewLine & _
"    Set sh = ThisWorkbook.Sheets(1)" & vbNewLine & _
"    With sh" & vbNewLine & _
"       y = .Cells(.Rows.Count, 1).End(xlUp).Row + 1" & vbNewLine & _
"        Set r = .Range(.Cells(1, 1), .Cells(y, 2))" & vbNewLine & _
"    End With" & vbNewLine & _
"    Dim arr As Variant" & vbNewLine & _
"    arr = r" & vbNewLine & _
"    " & vbNewLine & _
"    Dim e As Long" & vbNewLine
    
    For i = 0 To n
        txt = txt & _
"    Dim i" & i & " As Long" & vbNewLine
    Next

    txt = txt & _
"    Dim s As String" & vbNewLine & _
"    Dim dic As Object" & vbNewLine & _
"    Set dic = CreateObject(""Scripting.Dictionary"")" & vbNewLine & _
"    For y = 1 To UBound(arr, 1) - 1" & vbNewLine & _
"        For e = y To UBound(arr, 1) - 1" & vbNewLine & _
"            If arr(e + 1, 1) <> arr(e, 1) Then Exit For" & vbNewLine & _
"        Next" & vbNewLine & _
"        If e > y Then" & vbNewLine & _
"            i0 = y - 1" & vbNewLine

    For i = 1 To n
        txt = txt & _
"            For i" & i & " = i" & i - 1 & " + 1 To e - " & n - (i - 0) & vbNewLine
    Next
    
    txt = txt & _
"                s = Join(Array(arr(i1, 2)"
    For i = 2 To n
        txt = txt & ", arr(i" & i & ", 2)"
    Next
    txt = txt & "), vbTab)" & vbNewLine

    txt = txt & _
"                dic.Item(s) = dic.Item(s) + 1" & vbNewLine

    For i = 1 To n
        txt = txt & _
"            Next" & vbNewLine
    Next

    txt = txt & _
"            y = e" & vbNewLine & _
"        End If" & vbNewLine & _
"    Next" & vbNewLine & _
"    Set GetDic = dic" & vbNewLine & _
"End Function" & vbNewLine

    SubText1 = txt
End Function

'--------------------------------------------------------------------------------------------------
Private Function Check_VBOM_Access() As Boolean
    Dim VBProj As Object 'VBIDE.VBProject
    On Error Resume Next
        Set VBProj = ThisWorkbook.VBProject
    On Error GoTo 0
    If VBProj Is Nothing Then
        VBOM_Access
        Exit Function
    Else
        Check_VBOM_Access = True
    End If
End Function

Private Sub VBOM_Access_CheckBox()
' Включает доступ к объектной модели проектов VBA.
' Только проставляет галочку.
    Dim objExcelApp As Object, objShell As Object, sExVersion As String, lLevel As Long
 
    'Определяем версию Excel и в зависимости от этого определяем ветку реестра
    Set objExcelApp = CreateObject("Excel.Application")
    sExVersion = objExcelApp.Version: objExcelApp.Quit
 
    Set objShell = CreateObject("WScript.Shell")
    lLevel = objShell.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Office\" & sExVersion & "\Excel\Security\AccessVBOM")
    'Разрешаем доступ к объектной модели VBA
    'AccessVBOM - 0 - запрещен доступ; 1 - разрешен
    If lLevel = 0 Then
        objShell.RegWrite _
                "HKEY_CURRENT_USER\Software\Microsoft\Office\" & _
                sExVersion & "\Excel\Security\AccessVBOM", 1, "REG_DWORD"
        MsgBox _
        "Требуется перегрузка Excel." & vbLf & _
        "Разрешён доступ к объектной модели VBA." _
        , vbInformation, "Modules Export Import"
        
    End If
    Set objExcelApp = Nothing: Set objShell = Nothing
End Sub

Private Sub VBOM_Access()
    'Второй виток (повторный запуск)
    Dim CMDName As String
    CMDName = Environ("temp") & "\Excel_VBOM.tmp.cmd"
    If Dir$(CMDName) <> vbNullString Then Kill CMDName
     
    'Первый запуск
    Dim VBProj As Object
    On Error GoTo VBOM_Act
        Set VBProj = ThisWorkbook.VBProject
    On Error GoTo 0
    Set VBProj = Nothing
Exit Sub
     
VBOM_Act:

    Dim FF As Long
    FF = FreeFile()
    Open CMDName For Output As #FF 'Создаем командный файл, ожидающий завершения процессов Excel
        Print #FF, "chcp 1251"
        Print #FF, ":waiting"
        Print #FF, "tasklist |>nul FindStr /B /L /I /C:excel.exe&&goto :waiting"
        Print #FF, "reg add HKCU\Software\Microsoft\Office\" & Application.Version & "\Excel\Security /v AccessVBOM /t REG_DWORD /d 1 /f"
        Print #FF, "start """" """ & Application.Path & "\excel.exe"" """ & ThisWorkbook.FullName & """"
        Print #FF, "DEL """ & CMDName & """"
    Close #FF
     
    Shell "cmd /c """ & CMDName & """", 0
     
    MsgBox "Программе нужно настроить доступ к объектной модели VBA-проекта. Пожалуйста, закройте все экземпляры приложения Excel.", vbInformation, "Доступ к объектной модели проектов VBA"
End Sub

Изменено: МатросНаЗебре - 16.06.2021 10:52:04 (Удалил Stop)
 
Всем большое за помощь!
Создала код для 4 комбинаций
Работает отлично  8)  :)  
 
Цитата
МатросНаЗебре написал:
 Вот Вам штука позабористей. Так выглядит код для произвольного количества артикулов.
Интересно!)
но не запустился. на Stop указывает
Код
VBOM_Act:
    Stop
    Dim FF As Long
 
Удалите Stop.
 
Все ок, заработал. Круто  :) Спасибо!
Тестила на 2 3 - ок
На 4 не работает, указывает на
Код
Set r = .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
На 5 подвис совсем(

В таблице 16 тыс.строк
Изменено: vikttur - 26.06.2021 00:49:35
 
МатросНаЗебре, Добрый день.

Спустя некоторое время решила вернуться к своей статистике и в файле выдает ошибку.
Макрос на 4
Указывает так http://prntscr.com/20080w6

Подскажите, пожалуйста, в чем причина? Что-то нужно поправить?
Изменено: Wine Wine - 18.11.2021 17:38:39
Страницы: 1
Наверх