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
|