Дана задача: Рассчитайте количество и выведите все уникальные последовательности из символов: E, E, A, B, C
Задача решена на листе "задача и расчёт" с помощью формул, но также требуется вывести уникальные значения. В сети нашёл подходящий код, но он выводит все значения как уникальные, т.к. букв E - 2, то и результатов 120, а должно быть 60.
У кого есть идеи, прошу помощи разобраться с кодом, второй день ломаю голову, но пока только немного разобрался с используемыми функциями. С VBA ранее не сталкивался, поэтому жутко торможу, хотя код совсем небольшой.
Буду благодарен за любую помощь!
[vba]
Код
Dim r As Long, c As Long
Sub main() c = 2 r = 0 Pn "EEABC" End Sub
Public Sub Pn(S As String, Optional SS As String = "") Dim i As Integer If Len(S) = 1 Then r = r + 1 If r > Rows.Count Then c = c + 1: r = 1 Cells(r, c) = SS & S Else For i = 1 To Len(S) Pn Left$(S, i - 1) & Mid$(S, i + 1), SS & Mid$(S, i, 1) Next End If End Sub
[/vba]
Доброго времени суток всем!
Дана задача: Рассчитайте количество и выведите все уникальные последовательности из символов: E, E, A, B, C
Задача решена на листе "задача и расчёт" с помощью формул, но также требуется вывести уникальные значения. В сети нашёл подходящий код, но он выводит все значения как уникальные, т.к. букв E - 2, то и результатов 120, а должно быть 60.
У кого есть идеи, прошу помощи разобраться с кодом, второй день ломаю голову, но пока только немного разобрался с используемыми функциями. С VBA ранее не сталкивался, поэтому жутко торможу, хотя код совсем небольшой.
Буду благодарен за любую помощь!
[vba]
Код
Dim r As Long, c As Long
Sub main() c = 2 r = 0 Pn "EEABC" End Sub
Public Sub Pn(S As String, Optional SS As String = "") Dim i As Integer If Len(S) = 1 Then r = r + 1 If r > Rows.Count Then c = c + 1: r = 1 Cells(r, c) = SS & S Else For i = 1 To Len(S) Pn Left$(S, i - 1) & Mid$(S, i + 1), SS & Mid$(S, i, 1) Next End If End Sub
[p.s.]Уникальные перестановки можно получить с помощью объекта "Словарь". Поищите по строке: CreateObject("Scripting.Dictionary"). На Форуме много примеров.[/p.s.]
[p.s.]Уникальные перестановки можно получить с помощью объекта "Словарь". Поищите по строке: CreateObject("Scripting.Dictionary"). На Форуме много примеров.[/p.s.]Gustav
Поищите по строке: CreateObject("Scripting.Dictionary")
В готовых смотрел, по приведённой Вами ссылке перестановка без повторений, у меня - с повторениями. По поиску Scripting.Dictionary нашёл только одну тему, но там вопрос не раскрыт( Буду искать дальше.
Поищите по строке: CreateObject("Scripting.Dictionary")
В готовых смотрел, по приведённой Вами ссылке перестановка без повторений, у меня - с повторениями. По поиску Scripting.Dictionary нашёл только одну тему, но там вопрос не раскрыт( Буду искать дальше.
Public Sub Pn(S As String, Optional SS As String = "") Dim i As Integer If Len(S) = 1 Then r = r + 1 If r > Rows.Count Then c = c + 1: r = 1 Cells(r, c) = SS & S Else For i = 1 To Len(S) If InStr(Left(S, i - 1), Mid(S, i, 1)) = 0 Then Pn Left$(S, i - 1) & Mid$(S, i + 1), SS & Mid$(S, i, 1) End If Next End If End Sub
[/vba]
Попробуйте так [vba]
Код
Public Sub Pn(S As String, Optional SS As String = "") Dim i As Integer If Len(S) = 1 Then r = r + 1 If r > Rows.Count Then c = c + 1: r = 1 Cells(r, c) = SS & S Else For i = 1 To Len(S) If InStr(Left(S, i - 1), Mid(S, i, 1)) = 0 Then Pn Left$(S, i - 1) & Mid$(S, i + 1), SS & Mid$(S, i, 1) End If Next End If End Sub
Sub main() Set dicObject = CreateObject("Scripting.Dictionary") Pn "EEABC" Range("B1").Resize(UBound(dicObject.Keys()) + 1) = WorksheetFunction.Transpose(dicObject.Keys()) End Sub
Public Sub Pn(S As String, Optional SS As String = "") Dim i As Integer If Len(S) = 1 Then If Not dicObject.Exists(SS & S) Then dicObject.Add SS & S, "" Else For i = 1 To Len(S) Pn Left$(S, i - 1) & Mid$(S, i + 1), SS & Mid$(S, i, 1) Next End If End Sub
[/vba]
Для коллекции - еще версия со "Словарём": [vba]
Код
Option Explicit
Dim dicObject As Object
Sub main() Set dicObject = CreateObject("Scripting.Dictionary") Pn "EEABC" Range("B1").Resize(UBound(dicObject.Keys()) + 1) = WorksheetFunction.Transpose(dicObject.Keys()) End Sub
Public Sub Pn(S As String, Optional SS As String = "") Dim i As Integer If Len(S) = 1 Then If Not dicObject.Exists(SS & S) Then dicObject.Add SS & S, "" Else For i = 1 To Len(S) Pn Left$(S, i - 1) & Mid$(S, i + 1), SS & Mid$(S, i, 1) Next End If End Sub